SystemOrganization addCategory: #'Refactoring-Environment'! Object subclass: #BrowserEnvironment instanceVariableNames: 'label searchStrings' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !BrowserEnvironment 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]. ^AndEnvironment onEnvironment: self and: anEnvironment! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'lr 2/8/2009 12:28'! addSearchString: aString searchStrings isNil ifTrue: [ searchStrings := SortedCollection sortBlock: [ :a :b | (a indexOf: $: ifAbsent: [ a size ]) > (b indexOf: $: ifAbsent: [ b size ]) ] ]. (searchStrings includes: aString) ifFalse: [ searchStrings add: aString ]! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 6/10/2010 15:29'! allClasses "Answer all the unique non-metaclasses of all the classes and metaclasses in this environment." | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | classes add: each theNonMetaClass ]. ^ classes asArray! ! !BrowserEnvironment methodsFor: 'private' stamp: 'lr 9/4/2010 13:46'! allClassesDo: aBlock self class environment allClassesDo: [ :each | aBlock value: each; value: each class ]! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 6/10/2010 15:29'! allMetaClasses "Answer all the unique non-metaclasses of all metaclasses in this environment." | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | each isMeta ifTrue: [ classes add: each theNonMetaClass ] ]. ^ classes asArray! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 6/10/2010 15:29'! allNonMetaClasses "Answer all the unique non-metaclasses of all of all the non-metaclasses in this environment." | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | each isMeta ifFalse: [ classes add: each ] ]. ^ classes asArray! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'nk 3/4/2005 12:41'! asSelectorEnvironment ^(ClassEnvironment onEnvironment: self classes: self classes) asSelectorEnvironment! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 1/23/2010 17:10'! associationAt: aKey ^ self associationAt: aKey ifAbsent: [ self error: aKey printString , ' not found' ]! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 7/23/2010 07:55'! associationAt: aKey ifAbsent: aBlock | association class | association := Smalltalk globals 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 ]! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:46'! at: aKey ^ self at: aKey ifAbsent: [ self error: aKey printString , ' not found' ]! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 1/23/2010 17:15'! at: aKey ifAbsent: aBlock | association | association := self associationAt: aKey ifAbsent: [ nil ]. ^ association isNil ifTrue: [ aBlock value ] ifFalse: [ association value ]! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'lr 7/23/2010 07:53'! categories ^ Smalltalk organization categories select: [ :each | self includesCategory: each ]! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 11/25/2009 08:31'! classNames | names | names := IdentitySet new: 4096. self classesDo: [ :each | names add: each theNonMetaClass name ]. ^ names! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'lr 7/23/2010 07:55'! classNamesFor: aCategoryName ^ (Smalltalk organization listAtCategoryNamed: aCategoryName) select: [ :each | | class | class := Smalltalk globals at: each ifAbsent: [ nil ]. class notNil and: [ (self includesClass: class) or: [ self includesClass: class class ] ] ]! ! !BrowserEnvironment methodsFor: 'environments' stamp: 'lr 3/8/2009 19:07'! classVarRefsTo: instVarName in: aClass ^ VariableEnvironment on: self referencesToClassVariable: instVarName in: aClass! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! classVariablesFor: aClass ^aClass classVarNames! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:45'! classes | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | classes add: each ]. ^ classes! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! classesAndSelectorsDo: aBlock self classesDo: [:class | self selectorsForClass: class do: [:sel | aBlock value: class value: sel]]! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:45'! classesDo: aBlock self allClassesDo: [ :each | (self includesClass: each) ifTrue: [ aBlock value: each ] ]! ! !BrowserEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:23'! copyEmpty ^ self class new! ! !BrowserEnvironment methodsFor: 'private' stamp: ''! defaultLabel ^'Smalltalk'! ! !BrowserEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:37'! definesClass: aClass ^ true! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! forCategories: categoryList ^CategoryEnvironment onEnvironment: self categories: categoryList! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! forClass: aClass protocols: protocolCollection ^ProtocolEnvironment onEnvironment: self class: aClass protocols: protocolCollection! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! forClass: aClass selectors: selectorCollection ^(SelectorEnvironment onMethods: selectorCollection forClass: aClass in: self) label: aClass name , '>>' , (selectorCollection detect: [:each | true] ifNone: ['']); yourself! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! forClasses: classCollection | classes | classes := OrderedCollection new: classCollection size * 2. classCollection do: [:each | classes add: each; add: each class]. ^ClassEnvironment onEnvironment: self classes: classes! ! !BrowserEnvironment methodsFor: 'environments' stamp: 'lr 11/25/2009 08:56'! forPackageNames: aCollection ^ PackageEnvironment onEnvironment: self packageNames: aCollection! ! !BrowserEnvironment methodsFor: 'environments' stamp: 'lr 11/25/2009 08:55'! forPackages: aCollection ^ PackageEnvironment onEnvironment: self packages: aCollection! ! !BrowserEnvironment methodsFor: 'environments' stamp: 'lr 7/21/2008 10:38'! forPragmas: aKeywordCollection ^ PragmaEnvironment onEnvironment: self keywords: aKeywordCollection! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! implementorsMatching: aString ^SelectorEnvironment implementorsMatching: aString in: self! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! implementorsOf: aSelector ^SelectorEnvironment implementorsOf: aSelector in: self! ! !BrowserEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^true! ! !BrowserEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass ^true! ! !BrowserEnvironment methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^true! ! !BrowserEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^true! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! instVarReadersTo: instVarName in: aClass ^VariableEnvironment on: self readersOfInstanceVariable: instVarName in: aClass! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! instVarRefsTo: instVarName in: aClass ^VariableEnvironment on: self referencesToInstanceVariable: instVarName in: aClass! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! instVarWritersTo: instVarName in: aClass ^VariableEnvironment on: self writersOfInstanceVariable: instVarName in: aClass! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! instanceVariablesFor: aClass ^aClass instVarNames! ! !BrowserEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isClassEnvironment ^ false! ! !BrowserEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^false! ! !BrowserEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 13:00'! isSelectorEnvironment ^ false! ! !BrowserEnvironment methodsFor: 'testing' stamp: ''! isSystem ^true! ! !BrowserEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isVariableEnvironment ^ false! ! !BrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 7/23/2010 07:56'! keys | keys | keys := Set new. Smalltalk globals 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! ! !BrowserEnvironment methodsFor: 'private' stamp: ''! label ^label isNil ifTrue: [self defaultLabel] ifFalse: [label]! ! !BrowserEnvironment methodsFor: 'initialize-release' stamp: ''! label: aString label := aString! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! matches: aString ^SelectorEnvironment matches: aString in: self! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! not self isSystem ifTrue: [^SelectorEnvironment new]. ^NotEnvironment onEnvironment: self! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! numberClasses ^self classNames size! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! numberSelectors | total | total := 0. self allClassesDo: [:each | self selectorsForClass: each do: [:sel | total := total + 1]]. ^total! ! !BrowserEnvironment methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self label! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^self numberSelectors! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! protocolsFor: aClass ^aClass organization categories select: [:each | self includesProtocol: each in: aClass]! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! referencesTo: aLiteral ^SelectorEnvironment referencesTo: aLiteral in: self! ! !BrowserEnvironment 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! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! searchStrings ^searchStrings isNil ifTrue: [#()] ifFalse: [searchStrings]! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! searchStrings: aCollection searchStrings := aCollection! ! !BrowserEnvironment methodsFor: 'environments' stamp: ''! selectMethods: aBlock | env | env := SelectorEnvironment onEnvironment: self. self classesAndSelectorsDo: [:each :sel | (aBlock value: (each compiledMethodAt: sel)) ifTrue: [env addClass: each selector: sel]]. ^env! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'bh 5/8/2000 21:02'! selectionIntervalFor: aString | interval | self searchStrings isEmpty ifTrue: [^nil]. interval := self selectionParseTreeIntervalFor: aString. interval notNil ifTrue: [^interval]. self searchStrings do: [:each | | search index | search := each isSymbol ifTrue: [each keywords first] ifFalse: [each]. index := aString indexOfSubCollection: search startingAt: 1. index > 0 ifTrue: [^index to: index + search size - 1]]. ^nil! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'lr 9/4/2010 15:45'! selectionParseTreeIntervalFor: aString | parseTree answerBlock | parseTree := RBParser parseMethod: aString onError: [ :str :pos | ^ nil ]. answerBlock := [ :aNode :answer | ^ aNode sourceInterval ]. self searchStrings do: [ :each | | matcher tree | matcher := RBParseTreeSearcher new. matcher matchesTree: (RBLiteralNode value: each) do: answerBlock. each isSymbol ifTrue: [ tree := RBParseTreeSearcher buildSelectorTree: each. tree notNil ifTrue: [ matcher matchesTree: tree do: answerBlock ] ] ifFalse: [ tree := RBVariableNode named: each. matcher matchesTree: tree do: answerBlock; matchesArgumentTree: tree do: answerBlock ]. matcher executeTree: parseTree ]. ^ nil! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! selectorsFor: aProtocol in: aClass ^(aClass organization listAtCategoryNamed: aProtocol) select: [:each | self includesSelector: each in: aClass]! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'lr 2/26/2009 14:29'! selectorsForClass: aClass | selectors | selectors := IdentitySet new. self selectorsForClass: aClass do: [ :each | selectors add: each ]. ^ selectors! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! selectorsForClass: aClass do: aBlock aClass selectorsAndMethodsDo: [:each :meth | (self includesSelector: each in: aClass) ifTrue: [aBlock value: each]]! ! !BrowserEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPutAll: self class name; nextPutAll: ' new'! ! !BrowserEnvironment methodsFor: 'accessing' stamp: 'lr 7/23/2010 07:55'! whichCategoryIncludes: aClassName ^ Smalltalk organization categoryOfElement: aClassName! ! !BrowserEnvironment methodsFor: 'accessing' stamp: ''! whichProtocolIncludes: aSelector in: aClass ^aClass organization categoryOfElement: aSelector! ! !BrowserEnvironment methodsFor: 'environments' stamp: 'lr 11/25/2009 00:50'! | 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]. ^ OrEnvironment onEnvironment: self or: anEnvironment! ! BrowserEnvironment subclass: #BrowserEnvironmentWrapper instanceVariableNames: 'environment' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! BrowserEnvironmentWrapper subclass: #AndEnvironment instanceVariableNames: 'andedEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !AndEnvironment class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment and: anotherEnvironment ^(self onEnvironment: anEnvironment) andedEnvironment: anotherEnvironment; yourself! ! !AndEnvironment methodsFor: 'private' stamp: ''! andedEnvironment ^andedEnvironment! ! !AndEnvironment methodsFor: 'initialize-release' stamp: ''! andedEnvironment: aBrowserEnvironment andedEnvironment := aBrowserEnvironment! ! !AndEnvironment methodsFor: 'accessing' stamp: ''! classesDo: aBlock environment classesDo: [:each | (self includesClass: each) ifTrue: [aBlock value: each]]! ! !AndEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !AndEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass | doesntHaveSelectors | (environment includesClass: aClass) ifFalse: [^false]. (andedEnvironment includesClass: aClass) ifFalse: [^false]. doesntHaveSelectors := true. environment selectorsForClass: aClass do: [:each | doesntHaveSelectors := false. (andedEnvironment includesSelector: each in: aClass) ifTrue: [^true]]. ^doesntHaveSelectors! ! !AndEnvironment methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^(self selectorsFor: aProtocol in: aClass) isEmpty not! ! !AndEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) and: [andedEnvironment includesSelector: aSelector in: aClass]! ! !AndEnvironment methodsFor: 'accessing' stamp: ''! numberSelectors | total | total := 0. environment classesAndSelectorsDo: [:each :sel | (andedEnvironment includesSelector: sel in: each) ifTrue: [total := total + 1]]. ^total! ! !AndEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^environment isClassEnvironment ifTrue: [self numberClasses] ifFalse: [super problemCount]! ! !AndEnvironment methodsFor: 'accessing' stamp: 'bh 5/8/2000 21:01'! selectionIntervalFor: aString | interval | interval := super selectionIntervalFor: aString. interval notNil ifTrue: [^interval]. ^andedEnvironment selectionIntervalFor: aString ! ! !AndEnvironment methodsFor: 'accessing' stamp: ''! selectorsForClass: aClass do: aBlock environment selectorsForClass: aClass do: [:each | (andedEnvironment includesSelector: each in: aClass) ifTrue: [aBlock value: each]]! ! !AndEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. environment storeOn: aStream. aStream nextPutAll: ' & '. andedEnvironment storeOn: aStream. aStream nextPut: $)! ! !BrowserEnvironmentWrapper class methodsFor: 'instance creation' stamp: ''! new ^self onEnvironment: BrowserEnvironment new! ! !BrowserEnvironmentWrapper class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment ^(self basicNew) initialize; onEnvironment: anEnvironment; yourself! ! !BrowserEnvironmentWrapper methodsFor: 'testing' stamp: 'lr 11/25/2009 08:38'! definesClass: aClass ^ environment definesClass: aClass! ! !BrowserEnvironmentWrapper methodsFor: 'private' stamp: ''! environment ^environment! ! !BrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^environment includesCategory: aCategory! ! !BrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesClass: aClass ^environment includesClass: aClass! ! !BrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^(self includesClass: aClass) and: [environment includesProtocol: aProtocol in: aClass]! ! !BrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(self includesClass: aClass) and: [environment includesSelector: aSelector in: aClass]! ! !BrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! isEmpty self classesDo: [:each | ^false]. ^true! ! !BrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! isSystem ^false! ! !BrowserEnvironmentWrapper methodsFor: 'initialize-release' stamp: ''! onEnvironment: anEnvironment environment := anEnvironment! ! !BrowserEnvironmentWrapper methodsFor: 'accessing' stamp: 'bh 5/8/2000 21:03'! selectionIntervalFor: aString | interval | interval := super selectionIntervalFor: aString. ^interval notNil ifTrue: [interval] ifFalse: [environment selectionIntervalFor: aString]! ! !BrowserEnvironmentWrapper methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPutAll: '('; nextPutAll: self class name; nextPutAll: ' onEnvironment: '. environment storeOn: aStream. aStream nextPut: $)! ! BrowserEnvironmentWrapper subclass: #CategoryEnvironment instanceVariableNames: 'categories' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !CategoryEnvironment class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment categories: aCollection ^(self onEnvironment: anEnvironment) categories: aCollection; yourself! ! !CategoryEnvironment methodsFor: 'adding' stamp: 'lr 2/8/2009 10:46'! addCategory: aSymbol categories add: aSymbol! ! !CategoryEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 14:25'! categories: aCollection categories addAll: aCollection! ! !CategoryEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:32'! classNames ^ self categories inject: IdentitySet new into: [ :answer :each | answer addAll: (self classNamesFor: each); yourself ]! ! !CategoryEnvironment methodsFor: 'private' stamp: ''! defaultLabel | stream | stream := String new writeStream. categories do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! !CategoryEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(categories includes: aCategory) and: [super includesCategory: aCategory]! ! !CategoryEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:31'! includesClass: aClass ^ (super includesClass: aClass) and: [ categories includes: aClass theNonMetaClass category ]! ! !CategoryEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 14:25'! initialize super initialize. categories := IdentitySet new! ! !CategoryEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^categories isEmpty! ! !CategoryEnvironment methodsFor: 'accessing' stamp: ''! numberSelectors | total | total := 0. self classesDo: [:each | self selectorsForClass: each do: [:sel | total := total + 1]]. ^total! ! !CategoryEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:21'! postCopy super postCopy. categories := categories copy! ! !CategoryEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' categories: '. categories asArray storeOn: aStream. aStream nextPut: $)! ! BrowserEnvironmentWrapper subclass: #ClassEnvironment instanceVariableNames: 'classes metaClasses' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !ClassEnvironment class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment classes: aCollection ^(self onEnvironment: anEnvironment) classes: aCollection; yourself! ! !ClassEnvironment methodsFor: 'adding' stamp: ''! addClass: aClass aClass isMeta ifTrue: [metaClasses add: aClass soleInstance name] ifFalse: [classes add: aClass name]! ! !ClassEnvironment methodsFor: 'accessing' stamp: 'bh 6/10/2000 17:05'! asSelectorEnvironment ^SelectorEnvironment new searchStrings:#(); label:self label; onEnvironment: self environment; classSelectors: self classSelectorDictionary metaClassSelectors: self metaClassSelectorDictionary; yourself.! ! !ClassEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:24'! classNames ^ IdentitySet new addAll: classes; addAll: metaClasses; yourself! ! !ClassEnvironment methodsFor: 'printing' stamp: 'lr 7/23/2010 07:57'! classSelectorDictionary ^ classes inject: (IdentityDictionary new: classes size) into: [ :answer :class | answer at: class put: (Smalltalk globals at: class) selectors; yourself ]! ! !ClassEnvironment methodsFor: 'initialize-release' stamp: ''! classes: aCollection aCollection do: [:each | self addClass: each]! ! !ClassEnvironment methodsFor: 'accessing-classes' stamp: 'lr 7/23/2010 07:57'! classesDo: aBlock classes do: [ :each | | class | class := Smalltalk globals at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class ]) ifTrue: [ aBlock value: class ] ]. metaClasses do: [ :each | | class | class := Smalltalk globals at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class class ]) ifTrue: [ aBlock value: class class ] ]! ! !ClassEnvironment methodsFor: 'private' stamp: ''! defaultLabel | stream | stream := String new writeStream. classes do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! !ClassEnvironment methodsFor: 'testing' stamp: 'lr 7/23/2010 07:59'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ (environment classNamesFor: aCategory) inject: false into: [ :bool :each | bool or: [ | class | class := Smalltalk globals at: each ifAbsent: [ nil ]. class notNil and: [ (self includesClass: class) or: [ self includesClass: class class ] ] ] ] ]! ! !ClassEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass ^(aClass isMeta ifTrue: [metaClasses includes: aClass soleInstance name] ifFalse: [classes includes: aClass name]) and: [super includesClass: aClass]! ! !ClassEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 13:35'! initialize super initialize. classes := IdentitySet new. metaClasses := IdentitySet new! ! !ClassEnvironment methodsFor: 'testing' stamp: ''! isClassEnvironment ^true! ! !ClassEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^classes isEmpty and: [metaClasses isEmpty]! ! !ClassEnvironment methodsFor: 'printing' stamp: 'lr 7/23/2010 07:57'! metaClassSelectorDictionary ^ metaClasses inject: (IdentityDictionary new: metaClasses size) into: [ :answer :class | answer at: class put: (Smalltalk globals at: class) class selectors; yourself ]! ! !ClassEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:24'! postCopy super postCopy. classes := classes copy. metaClasses := metaClasses copy! ! !ClassEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^self numberClasses! ! !ClassEnvironment methodsFor: 'removing' stamp: ''! removeClass: aClass aClass isMeta ifTrue: [metaClasses remove: aClass soleInstance name ifAbsent: []] ifFalse: [classes remove: aClass name ifAbsent: []]! ! !ClassEnvironment 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])))'! ! BrowserEnvironmentWrapper subclass: #NotEnvironment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !NotEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !NotEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass (environment includesClass: aClass) ifFalse: [^true]. aClass selectorsAndMethodsDo: [:each :meth | (environment includesSelector: each in: aClass) ifFalse: [^true]]. ^false! ! !NotEnvironment methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^(self selectorsFor: aProtocol in: aClass) isEmpty not! ! !NotEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) not! ! !NotEnvironment methodsFor: 'environments' stamp: ''! not ^environment! ! !NotEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream environment storeOn: aStream. aStream nextPutAll: ' not'! ! BrowserEnvironmentWrapper subclass: #OrEnvironment instanceVariableNames: 'orEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !OrEnvironment class methodsFor: 'as yet unclassified' stamp: 'lr 11/25/2009 00:51'! onEnvironment: anEnvironment or: anotherEnvironment ^ (self onEnvironment: anEnvironment) orEnvironment: anotherEnvironment; yourself! ! !OrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:25'! classesDo: aBlock | enumerated | enumerated := IdentitySet new. environment classesDo: [ :each | aBlock value: each. enumerated add: each]. orEnvironment classesDo: [ :each | (enumerated includes: each) ifFalse: [ aBlock value: each ] ]! ! !OrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:26'! includesCategory: aCategory ^ (environment includesCategory: aCategory) or: [ orEnvironment includesCategory: aCategory ]! ! !OrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 00:53'! includesClass: aClass (environment includesClass: aClass) ifTrue: [ ^ true ]. (orEnvironment includesClass: aClass) ifTrue: [ ^ true ]. (environment selectorsForClass: aClass) isEmpty ifFalse: [ ^ true ]. (orEnvironment selectorsForClass: aClass) isEmpty ifFalse: [ ^ true ]. ^ false! ! !OrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 00:53'! includesProtocol: aProtocol in: aClass ^ (environment includesProtocol: aProtocol in: aClass) or: [ orEnvironment includesProtocol: aProtocol in: aClass ]! ! !OrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 00:53'! includesSelector: aSelector in: aClass ^ (environment includesSelector: aSelector in: aClass) or: [ orEnvironment includesSelector: aSelector in: aClass ]! ! !OrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:25'! numberSelectors | total | total := 0. self classesDo: [ :each | self selectorsForClass: each do: [ :selector | total := total + 1 ] ]. ^ total! ! !OrEnvironment methodsFor: 'initialization' stamp: 'lr 11/25/2009 00:49'! orEnvironment: aBrowserEnvironment orEnvironment := aBrowserEnvironment! ! !OrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 00:54'! selectionIntervalFor: aString ^ (environment selectionIntervalFor: aString) ifNil: [ orEnvironment selectionIntervalFor: aString ]! ! !OrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:26'! selectorsForClass: aClass do: aBlock | enumerated | enumerated := IdentitySet new. environment selectorsForClass: aClass do: [ :each | enumerated add: each. aBlock value: each ]. orEnvironment selectorsForClass: aClass do: [:each | (enumerated includes: each) ifFalse: [ aBlock value: each ] ]! ! !OrEnvironment methodsFor: 'printing' stamp: 'lr 11/25/2009 00:51'! storeOn: aStream aStream nextPut: $(. environment storeOn: aStream. aStream nextPutAll: ' | '. orEnvironment storeOn: aStream. aStream nextPut: $)! ! BrowserEnvironmentWrapper subclass: #PackageEnvironment instanceVariableNames: 'packages' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !PackageEnvironment class methodsFor: 'instance creation' stamp: 'lr 11/25/2009 08:54'! onEnvironment: anEnvironment packageNames: aCollection ^ self onEnvironment: anEnvironment packages: (aCollection collect: [ :each | PackageInfo named: each ])! ! !PackageEnvironment class methodsFor: 'instance creation' stamp: 'lr 11/25/2009 08:54'! onEnvironment: anEnvironment packages: aCollection ^ (self onEnvironment: anEnvironment) packages: aCollection; yourself! ! !PackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:48'! asSelectorEnvironment | result | result := SelectorEnvironment onEnvironment: environment. self classesAndSelectorsDo: [ :class :selector | result addClass: class selector: selector ]. ^ result! ! !PackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:48'! classesAndSelectorsDo: aBlock packages do: [ :package | package methods do: [ :method | (environment includesSelector: method methodSymbol in: method actualClass) ifTrue: [ aBlock value: method actualClass value: method methodSymbol ] ] ]! ! !PackageEnvironment methodsFor: 'accessing' stamp: 'lr 12/3/2009 10:16'! classesDo: aBlock | enumerated enumerator | enumerated := IdentitySet new. enumerator := [ :each | (enumerated includes: each) ifFalse: [ (environment includesClass: each) ifTrue: [ aBlock value: each ]. (environment includesClass: each class) ifTrue: [ aBlock value: each class ]. enumerated add: each ] ]. packages do: [ :package | package classes do: enumerator. package extensionClasses do: enumerator ]! ! !PackageEnvironment methodsFor: 'testing' stamp: 'lr 5/15/2010 09:39'! definesClass: aClass ^ (super definesClass: aClass) and: [ self packages anySatisfy: [ :package | package includesClass: aClass ] ]! ! !PackageEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:51'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ self packages anySatisfy: [ :package | package includesSystemCategory: aCategory ] ]! ! !PackageEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 09:06'! includesClass: aClass ^ (super includesClass: aClass) and: [ self packages anySatisfy: [ :package | (package includesClass: aClass) or: [ (package extensionCategoriesForClass: aClass) notEmpty ] ] ]! ! !PackageEnvironment methodsFor: 'testing' stamp: 'lr 12/3/2009 10:13'! includesProtocol: aProtocol in: aClass ^ (environment includesProtocol: aProtocol in: aClass) and: [ self packages anySatisfy: [ :package | package includesMethodCategory: aProtocol ofClass: aClass ] ]! ! !PackageEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 10:33'! includesSelector: aSelector in: aClass ^ (environment includesSelector: aSelector in: aClass) and: [ self packages anySatisfy: [ :package | package includesMethod: aSelector ofClass: aClass ] ]! ! !PackageEnvironment methodsFor: 'initialize-release' stamp: 'lr 4/12/2010 15:25'! initialize super initialize. packages := Set new! ! !PackageEnvironment methodsFor: 'accessing' stamp: 'lr 12/3/2009 13:30'! numberSelectors ^ packages inject: 0 into: [ :result :package | result + package methods size ]! ! !PackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:49'! packageNames ^ packages collect: [ :each | each packageName ]! ! !PackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:46'! packages ^ packages! ! !PackageEnvironment methodsFor: 'initialize-release' stamp: 'lr 12/20/2009 09:29'! packages: aCollection packages addAll: aCollection! ! !PackageEnvironment methodsFor: 'copying' stamp: 'lr 4/12/2010 15:26'! postCopy super postCopy. packages := packages copy! ! !PackageEnvironment methodsFor: 'printing' stamp: 'TestRunner 12/23/2009 21:22'! storeOn: aStream aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' onEnvironment: '. environment storeOn: aStream. aStream nextPutAll: ' packageNames: '. self packageNames asArray storeOn: aStream. aStream nextPut: $)! ! BrowserEnvironmentWrapper subclass: #PragmaEnvironment instanceVariableNames: 'keywords condition' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !PragmaEnvironment class methodsFor: 'instance creation' stamp: 'lr 7/21/2008 10:38'! onEnvironment: anEnvironment keywords: aKeywordCollection ^ (self onEnvironment: anEnvironment) keywords: aKeywordCollection; yourself! ! !PragmaEnvironment methodsFor: 'adding' stamp: 'lr 7/21/2008 10:20'! addKeyword: aSymbol keywords add: aSymbol! ! !PragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 7/21/2008 10:34'! condition: aBlock condition := aBlock! ! !PragmaEnvironment methodsFor: 'private' stamp: 'lr 7/21/2008 10:40'! defaultLabel | stream | stream := String new writeStream. keywords do: [ :each | stream nextPut: $<; nextPutAll: each; nextPut: $>; nextPut: $ ]. ^ stream contents! ! !PragmaEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 12:42'! includesCategory: aCategory ^ (environment includesCategory: aCategory) and: [ (self classNamesFor: aCategory) notEmpty ]! ! !PragmaEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 10:43'! includesClass: aClass ^ (environment includesClass: aClass) and: [ aClass selectors anySatisfy: [ :each | self includesSelector: each in: aClass ] ]! ! !PragmaEnvironment methodsFor: 'testing' stamp: 'lr 7/21/2008 10:34'! includesPragma: aPragma ^ (keywords includes: aPragma keyword) and: [ condition value: aPragma ]! ! !PragmaEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 12:42'! includesProtocol: aProtocol in: aClass ^ (environment includesProtocol: aProtocol in: aClass) and: [ (self selectorsFor: aProtocol in: aClass) notEmpty ]! ! !PragmaEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:48'! includesSelector: aSelector in: aClass (environment includesSelector: aSelector in: aClass) ifFalse: [ ^ false ]. ^ (aClass compiledMethodAt: aSelector) pragmas anySatisfy: [ :each | self includesPragma: each ]! ! !PragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 13:35'! initialize super initialize. keywords := IdentitySet new. condition := [ :pragma | true ]! ! !PragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/24/2009 19:38'! keywords: aCollection keywords addAll: aCollection! ! !PragmaEnvironment methodsFor: 'copying' stamp: 'lr 7/21/2008 10:37'! postCopy super postCopy. keywords := keywords copy! ! !PragmaEnvironment methodsFor: 'printing' stamp: 'lr 7/21/2008 10:37'! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' keywords: '. keywords asArray storeOn: aStream. aStream nextPut: $)! ! BrowserEnvironmentWrapper subclass: #ProtocolEnvironment instanceVariableNames: 'class protocols' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !ProtocolEnvironment class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment class: aClass protocols: aCollection ^(self onEnvironment: anEnvironment) class: aClass protocols: aCollection; yourself! ! !ProtocolEnvironment methodsFor: 'initialize-release' stamp: ''! class: aClass protocols: aCollection class := aClass. protocols := aCollection! ! !ProtocolEnvironment methodsFor: 'private' stamp: ''! defaultLabel | stream | stream := String new writeStream. stream nextPutAll: class name; nextPut: $>. protocols do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! !ProtocolEnvironment methodsFor: 'testing' stamp: 'lr 7/23/2010 07:59'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ (environment classNamesFor: aCategory) inject: false into: [ :bool :each | bool or: [ | aClass | aClass := Smalltalk globals at: each ifAbsent: [ nil ]. aClass == class or: [ aClass class == class ] ] ] ]! ! !ProtocolEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass ^aClass == class and: [super includesClass: aClass]! ! !ProtocolEnvironment methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^aClass == class and: [(super includesProtocol: aProtocol in: aClass) and: [protocols includes: aProtocol]]! ! !ProtocolEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(super includesSelector: aSelector in: aClass) and: [protocols includes: (environment whichProtocolIncludes: aSelector in: aClass)]! ! !ProtocolEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^protocols isEmpty! ! !ProtocolEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:29'! postCopy super postCopy. protocols := protocols copy! ! !ProtocolEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' class: '; nextPutAll: class name; nextPutAll: ' protocols: '. protocols asArray storeOn: aStream. aStream nextPut: $)! ! BrowserEnvironmentWrapper subclass: #SelectorEnvironment instanceVariableNames: 'classSelectors metaClassSelectors' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !SelectorEnvironment class methodsFor: 'instance creation' stamp: ''! implementorsMatching: aString in: anEnvironment | classDict metaDict | classDict := IdentityDictionary new. metaDict := IdentityDictionary new. anEnvironment classesDo: [:class | | selectors | selectors := Set 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! ! !SelectorEnvironment class methodsFor: 'instance creation' stamp: ''! implementorsOf: aSelector in: anEnvironment | classDict metaDict selectors | classDict := IdentityDictionary new. metaDict := IdentityDictionary new. selectors := Array with: aSelector. anEnvironment classesDo: [:class | ((class includesSelector: aSelector) and: [anEnvironment includesSelector: aSelector in: class]) ifTrue: [class isMeta ifTrue: [metaDict at: class soleInstance name put: selectors] ifFalse: [classDict at: class name put: selectors]]]. ^(self onEnvironment: anEnvironment) classSelectors: classDict metaClassSelectors: metaDict; label: 'Implementors of ' , aSelector; yourself! ! !SelectorEnvironment class methodsFor: 'instance creation' stamp: ''! matches: aString in: anEnvironment | newEnvironment | newEnvironment := (self onEnvironment: anEnvironment) label: 'Matching: ' , aString; searchStrings: (Array with: aString); yourself. anEnvironment classesAndSelectorsDo: [:each :sel | | method | method := each compiledMethodAt: sel. method allLiterals do: [:lit | lit isString ifTrue: [(aString match: lit) ifTrue: [newEnvironment addClass: each selector: sel]]]]. ^newEnvironment! ! !SelectorEnvironment class methodsFor: 'instance creation' stamp: ''! onMethods: selectorCollection forClass: aClass in: anEnvironment | env | env := self onEnvironment: anEnvironment. selectorCollection do: [:each | env addClass: aClass selector: each]. ^env! ! !SelectorEnvironment class methodsFor: 'instance creation' stamp: 'cwp 5/10/2010 23:49'! referencesTo: aLiteral in: anEnvironment | classDict literalPrintString specialFlag specialByte | literalPrintString := aLiteral isVariableBinding ifTrue: [aLiteral key asString] ifFalse: [aLiteral isString ifTrue: [aLiteral] ifFalse: [aLiteral printString]]. classDict := Dictionary new. specialFlag := Smalltalk hasSpecialSelector: aLiteral ifTrueSetByte: [ :byte | specialByte := byte ]. anEnvironment classesDo: [:class | | selectors | selectors := (class thoroughWhichSelectorsReferTo: aLiteral special: specialFlag byte: specialByte) select: [:aSelector | anEnvironment includesSelector: aSelector in: class]. selectors isEmpty ifFalse: [classDict at: class put: selectors]]. ^(self onEnvironment: anEnvironment) on: classDict; label: 'References to: ' , literalPrintString; searchStrings: (Array with: literalPrintString); yourself! ! !SelectorEnvironment methodsFor: 'adding' stamp: 'lr 9/14/2010 11:40'! addClass: aClass aClass isMeta ifTrue: [ metaClassSelectors at: aClass soleInstance name put: aClass selectors asIdentitySet ] ifFalse: [ classSelectors at: aClass name put: aClass selectors asIdentitySet ]! ! !SelectorEnvironment methodsFor: 'adding' stamp: 'lr 2/26/2009 13:36'! addClass: aClass selector: aSymbol (aClass isMeta ifTrue: [ metaClassSelectors at: aClass soleInstance name ifAbsentPut: [ IdentitySet new ] ] ifFalse: [ classSelectors at: aClass name ifAbsentPut: [ IdentitySet new ] ]) add: aSymbol! ! !SelectorEnvironment methodsFor: 'accessing' stamp: 'rr 4/19/2004 16:06'! asSelectorEnvironment ^ self! ! !SelectorEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 13:35'! classNames ^ IdentitySet new addAll: classSelectors keys; addAll: metaClassSelectors keys; yourself! ! !SelectorEnvironment methodsFor: 'initialize-release' stamp: ''! classSelectors: classSelectorDictionary metaClassSelectors: metaClassSelectorDictionary classSelectors := classSelectorDictionary. metaClassSelectors := metaClassSelectorDictionary! ! !SelectorEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 13:36'! classes: classArray metaClasses: metaArray "Used to recreate an environment from its storeString" classSelectors := IdentityDictionary new. metaClassSelectors := IdentityDictionary new. classArray do: [ :each | classSelectors at: each first put: each last asIdentitySet ]. metaArray do: [ :each | metaClassSelectors at: each first put: each last asIdentitySet ]! ! !SelectorEnvironment methodsFor: 'accessing-classes' stamp: 'lr 7/23/2010 08:00'! classesDo: aBlock classSelectors keysDo: [ :each | | class | class := Smalltalk globals at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class ]) ifTrue: [ aBlock value: class ] ]. metaClassSelectors keysDo: [ :each | | class | class := Smalltalk globals at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class class ]) ifTrue: [ aBlock value: class class ] ]! ! !SelectorEnvironment methodsFor: 'private' stamp: ''! defaultLabel ^'some methods'! ! !SelectorEnvironment methodsFor: 'testing' stamp: 'TestRunner 1/3/2010 12:36'! includesCategory: aCategory ^(super includesCategory: aCategory) and: [(self classNamesFor: aCategory) anySatisfy: [:className | (classSelectors includesKey: className) or: [metaClassSelectors includesKey: className]]]! ! !SelectorEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass ^(self privateSelectorsForClass: aClass) isEmpty not and: [super includesClass: aClass]! ! !SelectorEnvironment methodsFor: 'testing' stamp: 'TestRunner 1/3/2010 12:36'! includesProtocol: aProtocol in: aClass ^(super includesProtocol: aProtocol in: aClass) and: [(environment selectorsFor: aProtocol in: aClass) anySatisfy: [:aSelector | self privateIncludesSelector: aSelector inClass: aClass]]! ! !SelectorEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) and: [self privateIncludesSelector: aSelector inClass: aClass]! ! !SelectorEnvironment methodsFor: 'initialize-release' stamp: ''! initialize super initialize. classSelectors := IdentityDictionary new. metaClassSelectors := IdentityDictionary new! ! !SelectorEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^classSelectors isEmpty and: [metaClassSelectors isEmpty]! ! !SelectorEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 13:00'! isSelectorEnvironment ^ true! ! !SelectorEnvironment methodsFor: 'accessing' stamp: ''! numberSelectors "This doesn't compute the correct result when a method that is included in our method list is not in the environment we are wrapping. It is implemented this way for efficiency." ^(classSelectors inject: 0 into: [:sum :each | sum + each size]) + (metaClassSelectors inject: 0 into: [:sum :each | sum + each size])! ! !SelectorEnvironment methodsFor: 'initialize-release' stamp: 'lr 9/14/2010 11:40'! on: aDictionary aDictionary keysAndValuesDo: [ :class :selectors | class isMeta ifTrue: [ metaClassSelectors at: class soleInstance name put: selectors asIdentitySet ] ifFalse: [ classSelectors at: class name put: selectors asIdentitySet ] ]! ! !SelectorEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:29'! postCopy | newDict | super postCopy. newDict := classSelectors copy. newDict keysAndValuesDo: [:key :value | newDict at: key put: value copy]. classSelectors := newDict. newDict := metaClassSelectors copy. newDict keysAndValuesDo: [:key :value | newDict at: key put: value copy]. metaClassSelectors := newDict! ! !SelectorEnvironment methodsFor: 'private' stamp: ''! privateIncludesSelector: aSelector inClass: aClass ^(self privateSelectorsForClass: aClass) includes: aSelector! ! !SelectorEnvironment methodsFor: 'private' stamp: ''! privateSelectorsForClass: aClass ^aClass isMeta ifTrue: [metaClassSelectors at: aClass soleInstance name ifAbsent: [#()]] ifFalse: [classSelectors at: aClass name ifAbsent: [#()]]! ! !SelectorEnvironment methodsFor: 'removing' stamp: ''! removeClass: aClass aClass isMeta ifTrue: [metaClassSelectors removeKey: aClass soleInstance name ifAbsent: []] ifFalse: [classSelectors removeKey: aClass name ifAbsent: []]! ! !SelectorEnvironment 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: []! ! !SelectorEnvironment methodsFor: 'accessing' stamp: ''! selectorsForClass: aClass do: aBlock ^(self privateSelectorsForClass: aClass) do: [:each | (aClass includesSelector: each) ifTrue: [aBlock value: each]]! ! !SelectorEnvironment 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: '))'! ! BrowserEnvironmentWrapper subclass: #VariableEnvironment instanceVariableNames: 'instanceVariables instanceVariableReaders instanceVariableWriters classVariables selectorCache' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !VariableEnvironment class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 19:35'! on: anEnvironment readersOfInstanceVariable: aString in: aClass | newEnv | newEnv := (self onEnvironment: anEnvironment) label: 'Readers of ''' , aString , ''' in ' , aClass name; yourself. (aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: [:cls | (cls whichSelectorsReallyRead: aString) isEmpty ifFalse: [newEnv addClass: cls instanceVariableReader: aString]]. ^newEnv! ! !VariableEnvironment class methodsFor: 'instance creation' stamp: 'md 1/17/2006 14:17'! on: anEnvironment referencesToClassVariable: aSymbol in: aClass | newEnv definingClass assoc | newEnv := (self onEnvironment: anEnvironment) label: 'References to ''' , aSymbol , ''' in ' , aClass name; yourself. definingClass := aClass whichClassDefinesClassVar: aSymbol. assoc := definingClass bindingOf: aSymbol. definingClass withAllSubclassesDo: [:cls | (cls whichSelectorsReferTo: assoc) isEmpty ifFalse: [newEnv addClass: cls classVariable: aSymbol]]. ^newEnv! ! !VariableEnvironment class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 19:35'! on: anEnvironment referencesToInstanceVariable: aString in: aClass | newEnv | newEnv := (self onEnvironment: anEnvironment) label: 'References to ''' , aString , ''' in ' , aClass name; yourself. (aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: [:cls | ((cls whichSelectorsReallyRead: aString) isEmpty not or: [(cls whichSelectorsAssign: aString) isEmpty not]) ifTrue: [newEnv addClass: cls instanceVariable: aString]]. ^newEnv! ! !VariableEnvironment class methodsFor: 'instance creation' stamp: 'nk 3/4/2005 13:17'! on: anEnvironment writersOfInstanceVariable: aString in: aClass | newEnv | newEnv := (self onEnvironment: anEnvironment) label: 'Writers of ''' , aString , ''' in ' , aClass name; yourself. (aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: [:cls | (cls whichSelectorsAssign: aString) isEmpty ifFalse: [newEnv addClass: cls instanceVariableWriter: aString]]. ^newEnv! ! !VariableEnvironment class methodsFor: 'instance creation' stamp: ''! readersOfInstanceVariable: aString in: aClass ^self on: BrowserEnvironment new readersOfInstanceVariable: aString in: aClass! ! !VariableEnvironment class methodsFor: 'instance creation' stamp: ''! referencesToClassVariable: aSymbol in: aClass ^self on: BrowserEnvironment new referencesToClassVariable: aSymbol in: aClass! ! !VariableEnvironment class methodsFor: 'instance creation' stamp: ''! referencesToInstanceVariable: aString in: aClass ^self on: BrowserEnvironment new referencesToInstanceVariable: aString in: aClass! ! !VariableEnvironment class methodsFor: 'instance creation' stamp: ''! writersOfInstanceVariable: aString in: aClass ^self on: BrowserEnvironment new writersOfInstanceVariable: aString in: aClass! ! !VariableEnvironment methodsFor: 'private' stamp: ''! accessorMethods ^#(#instanceVariables #instanceVariableReaders #instanceVariableWriters #classVariables)! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass classVariable: aSymbol (classVariables at: aClass name ifAbsentPut: [Set new]) add: aSymbol. self flushCachesFor: aClass. self addSearchString: aSymbol! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass instanceVariable: aString (instanceVariables at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass instanceVariableReader: aString (instanceVariableReaders at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass instanceVariableWriter: aString (instanceVariableWriters at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !VariableEnvironment 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! ! !VariableEnvironment methodsFor: 'private' stamp: 'lr 7/23/2010 08:02'! classForName: aString | name isMeta class | isMeta := aString includes: $ . name := (isMeta ifTrue: [ aString copyFrom: 1 to: (aString size - 6 max: 1) ] ifFalse: [ aString ]) asSymbol. class := Smalltalk globals at: name ifAbsent: [ nil ]. ^ (class notNil and: [ isMeta ]) ifTrue: [ class class ] ifFalse: [ class ]! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! classNamesWithVariables | classNames | classNames := Set new. classNames addAll: instanceVariables keys; addAll: instanceVariableReaders keys; addAll: instanceVariableWriters keys; addAll: classVariables keys. ^classNames! ! !VariableEnvironment methodsFor: 'private' stamp: 'lr 11/25/2009 08:32'! classVariableSelectorsFor: aClass | selectors classVars | selectors := Set new. classVars := Set new. classVariables keysDo: [:each | | cls | cls := self classForName: each. (cls notNil and: [aClass theNonMetaClass includesBehavior: cls]) ifTrue: [classVars addAll: (classVariables at: each)]]. classVars do: [:each | | binding | binding := aClass bindingOf: each. binding notNil ifTrue: [selectors addAll: (aClass whichSelectorsReferTo: binding)]]. ^selectors! ! !VariableEnvironment methodsFor: 'private' stamp: ''! classVariables ^classVariables! ! !VariableEnvironment methodsFor: 'private' stamp: ''! classVariables: anObject classVariables := anObject! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! classVariablesFor: aClass ^classVariables at: aClass name ifAbsent: [#()]! ! !VariableEnvironment methodsFor: 'private' stamp: ''! computeSelectorCacheFor: aClass ^(self instanceVariableSelectorsFor: aClass) addAll: (self classVariableSelectorsFor: aClass); yourself! ! !VariableEnvironment methodsFor: 'copying' stamp: ''! copyDictionary: aDictionary | copy | copy := Dictionary new: aDictionary size. aDictionary keysAndValuesDo: [:key :value | copy at: key put: value]. ^copy! ! !VariableEnvironment methodsFor: 'accessing' stamp: 'md 1/17/2006 14:17'! environmentForClassVariable: aSymbol in: aClass | selectorEnvironment assoc block | selectorEnvironment := SelectorEnvironment 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! ! !VariableEnvironment methodsFor: 'accessing' stamp: 'lr 4/29/2010 19:35'! environmentForInstanceVariable: aString in: aClass | selectorEnvironment isReader isWriter | selectorEnvironment := SelectorEnvironment onEnvironment: self. selectorEnvironment addSearchString: aString. isReader := isWriter := false. ((instanceVariables at: aClass name ifAbsent: [#()]) includes: aString) ifTrue: [isReader := true. isWriter := true]. ((instanceVariableWriters at: aClass name ifAbsent: [#()]) includes: aString) ifTrue: [isWriter := true]. ((instanceVariableReaders at: aClass name ifAbsent: [#()]) includes: aString) ifTrue: [isReader := true]. aClass withAllSubAndSuperclassesDo: [:each | isWriter ifTrue: [(each whichSelectorsAssign: aString) do: [:sel | selectorEnvironment addClass: each selector: sel]]. isReader ifTrue: [(each whichSelectorsReallyRead: aString) do: [:sel | selectorEnvironment addClass: each selector: sel]]]. ^selectorEnvironment! ! !VariableEnvironment methodsFor: 'private' stamp: 'lr 11/25/2009 00:40'! flushCachesFor: aClass selectorCache isNil ifTrue: [ ^ self] . aClass theNonMetaClass withAllSubclasses do: [ :each | selectorCache removeKey: each ifAbsent: []; removeKey: each class ifAbsent: [] ]! ! !VariableEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !VariableEnvironment methodsFor: 'testing' stamp: 'lr 2/9/2008 10:51'! includesClass: aClass (super includesClass: aClass) ifFalse: [^false]. (instanceVariables includesKey: aClass name) ifTrue: [^true]. (classVariables includesKey: aClass name) ifTrue: [^true]. ^((self selectorCacheFor: aClass) detect: [:each | self includesSelector: each in: aClass] ifNone: [nil]) notNil! ! !VariableEnvironment methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^(self selectorsFor: aProtocol in: aClass) isEmpty not! ! !VariableEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSymbol in: aClass ^(environment includesSelector: aSymbol in: aClass) and: [(self selectorCacheFor: aClass) includes: aSymbol]! ! !VariableEnvironment methodsFor: 'initialize-release' stamp: ''! initialize super initialize. instanceVariables := Dictionary new. classVariables := Dictionary new. instanceVariableReaders := Dictionary new. instanceVariableWriters := Dictionary new! ! !VariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableReaders ^instanceVariableReaders! ! !VariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableReaders: anObject instanceVariableReaders := anObject! ! !VariableEnvironment methodsFor: 'private' stamp: 'lr 4/29/2010 19:35'! instanceVariableSelectorsFor: aClass | selectors | selectors := Set new. #(#instanceVariables #instanceVariableReaders #instanceVariableWriters) with: #(#whichSelectorsAccess: #whichSelectorsReallyRead: #whichSelectorsAssign:) do: [:var :sel | | instVars | instVars := Set new. (self perform: var) keysDo: [:each | | cls | cls := self classForName: each. (cls notNil and: [aClass includesBehavior: cls]) ifTrue: [instVars addAll: ((self perform: var) at: each)]]. instVars do: [:each | selectors addAll: (aClass perform: sel with: each)]]. ^selectors! ! !VariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableWriters ^instanceVariableWriters! ! !VariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableWriters: anObject instanceVariableWriters := anObject! ! !VariableEnvironment methodsFor: 'private' stamp: ''! instanceVariables ^instanceVariables! ! !VariableEnvironment methodsFor: 'private' stamp: ''! instanceVariables: anObject instanceVariables := anObject! ! !VariableEnvironment 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! ! !VariableEnvironment methodsFor: 'testing' stamp: 'TestRunner 1/3/2010 11:29'! isEmpty ^ self accessorMethods allSatisfy: [ :each | (self perform: each) isEmpty ]! ! !VariableEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isVariableEnvironment ^ true! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! numberVariables ^self accessorMethods inject: 0 into: [:sum :each | sum + ((self perform: each) inject: 0 into: [:s :e | s + e size])]! ! !VariableEnvironment methodsFor: 'copying' stamp: ''! postCopy super postCopy. instanceVariables := self copyDictionary: instanceVariables. instanceVariableReaders := self copyDictionary: instanceVariableReaders. instanceVariableWriters := self copyDictionary: instanceVariableWriters. classVariables := self copyDictionary: classVariables. selectorCache := nil! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^self numberVariables! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass classVariable: aSymbol | vars | vars := classVariables at: aClass name ifAbsent: [Set new]. vars remove: aSymbol ifAbsent: []. vars isEmpty ifTrue: [classVariables removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass instanceVariable: aString | vars | vars := instanceVariables at: aClass name ifAbsent: [Set new]. vars remove: aString ifAbsent: []. vars isEmpty ifTrue: [instanceVariables removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass instanceVariableReader: aString | vars | vars := instanceVariableReaders at: aClass name ifAbsent: [Set new]. vars remove: aString ifAbsent: []. vars isEmpty ifTrue: [instanceVariableReaders removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !VariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass instanceVariableWriter: aString | vars | vars := instanceVariableWriters at: aClass name ifAbsent: [Set new]. vars remove: aString ifAbsent: []. vars isEmpty ifTrue: [instanceVariableWriters removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !VariableEnvironment methodsFor: 'private' stamp: ''! selectorCache ^selectorCache isNil ifTrue: [selectorCache := Dictionary new] ifFalse: [selectorCache]! ! !VariableEnvironment methodsFor: 'private' stamp: 'lr 11/25/2009 00:42'! selectorCacheFor: aClass ^self selectorCache at: aClass name ifAbsentPut: [ self computeSelectorCacheFor: aClass ]! ! !VariableEnvironment methodsFor: 'printing' stamp: 'lr 4/29/2010 19:06'! storeOn: aStream aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' new '. self accessorMethods do: [ :each | aStream nextPutAll: each; nextPutAll: ': '. (self perform: each) storeOn: aStream. aStream nextPutAll: '; ']. aStream nextPutAll: 'yourself)'! !