[etoys-notify] Etoys: PackageInfo-Base-bf.42.mcz

[commits at source.squeak.org]

Bert Freudenberg uploaded a new version of PackageInfo-Base to project Etoys:
http://source.squeak.org/etoys/PackageInfo-Base-bf.42.mcz

==================== Summary ====================

Name: PackageInfo-Base-bf.42
Author: bf
Time: 19 April 2010, 2:59:54.127 am
UUID: 78ff57ba-4f49-4046-a25a-274c29fa036e
Ancestors: PackageInfo-Base-bp.41

- rename a temp shadowing an inst var

==================== Snapshot ====================

SystemOrganization addCategory: #'PackageInfo-Base'!

(PackageInfo named: 'PackageInfo-Base') postscript: 'nil'!

----- Method: MethodReference>>sourceCode (in category '*packageinfo-base') -----
sourceCode
	^ self actualClass sourceCodeAt: methodSymbol!

----- Method: Character>>escapeEntities (in category '*packageinfo-base') -----
escapeEntities
	#($< '&lt;' $> '&gt;' $& '&amp;') pairsDo:
		[:k :v |
		self = k ifTrue: [^ v]].
	^ String with: self!

----- Method: Collection>>gather: (in category '*packageinfo-base') -----
gather: aBlock
	^ Array streamContents:
		[:stream |
		self do: [:ea | stream nextPutAll: (aBlock value: ea)]]!

Object subclass: #PackageInfo
	instanceVariableNames: 'packageName methodCategoryPrefix preamble postscript preambleOfRemoval postscriptOfRemoval'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PackageInfo-Base'!
PackageInfo class
	instanceVariableNames: 'default'!

!PackageInfo commentStamp: '<historical>' prior: 0!
Subclass this class to create new Packages.!
PackageInfo class
	instanceVariableNames: 'default'!

----- Method: PackageInfo class>>allPackages (in category 'packages access') -----
allPackages
	^PackageOrganizer default packages!

----- Method: PackageInfo class>>default (in category 'compatibility') -----
default
	^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]!

----- Method: PackageInfo class>>initialize (in category 'class initialization') -----
initialize
	self allSubclassesDo: [:ea | ea new register]!

----- Method: PackageInfo class>>named: (in category 'packages access') -----
named: aString
	^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]!

----- Method: PackageInfo class>>registerPackage: (in category 'as yet unclassified') -----
registerPackage: aString
	"for compatibility with old fileOuts"
	^ Smalltalk at: #FilePackageManager ifPresent: [:p | p registerPackage: aString]!

----- Method: PackageInfo class>>registerPackageName: (in category 'packages access') -----
registerPackageName: aString
	^ PackageOrganizer default registerPackageNamed: aString!

----- Method: PackageInfo>>= (in category 'comparing') -----
= other
	^ other species = self species and: [other packageName = self packageName]!

----- Method: PackageInfo>>addCoreMethod: (in category 'modifying') -----
addCoreMethod: aMethodReference
	| category |
	category := self baseCategoryOfMethod: aMethodReference.
	aMethodReference actualClass organization
		classify: aMethodReference methodSymbol
		under: category
		suppressIfDefault: false!

----- Method: PackageInfo>>addExtensionMethod: (in category 'modifying') -----
addExtensionMethod: aMethodReference
	| category |
	category := self baseCategoryOfMethod: aMethodReference.
	aMethodReference actualClass organization
		classify: aMethodReference methodSymbol
		under: self methodCategoryPrefix, '-', category!

----- Method: PackageInfo>>addMethod: (in category 'modifying') -----
addMethod: aMethodReference
	(self includesClass: aMethodReference class)
		ifTrue: [self addCoreMethod: aMethodReference]
		ifFalse: [self addExtensionMethod: aMethodReference]!

----- Method: PackageInfo>>allOverriddenMethods (in category 'listing') -----
allOverriddenMethods
	"search classes and meta classes"
	^ Array streamContents: [:stream |
		self allOverriddenMethodsDo: [:each | stream nextPut: each]]
!

----- Method: PackageInfo>>allOverriddenMethodsDo: (in category 'enumerating') -----
allOverriddenMethodsDo: aBlock
	"Evaluates aBlock with all the overridden methods in the system"
	^ ProtoObject withAllSubclassesDo: [:class | 
		self overriddenMethodsInClass: class do: aBlock]
!

----- Method: PackageInfo>>baseCategoryOfMethod: (in category 'modifying') -----
baseCategoryOfMethod: aMethodReference
	| oldCat oldPrefix tokens | 
	oldCat := aMethodReference category.
	({ 'as yet unclassified'. 'all' } includes: oldCat) ifTrue: [ oldCat := '' ].
	tokens := oldCat findTokens: '*-' keep: '*'.

	"Strip off any old prefixes"
	((tokens at: 1 ifAbsent: [ '' ]) = '*') ifTrue: [
		[ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ]
			whileTrue: [ tokens removeFirst ].
		oldPrefix := tokens removeFirst asLowercase.
		[ (tokens at: 1 ifAbsent: [ '' ]) asLowercase = oldPrefix ]
			whileTrue: [ tokens removeFirst ].
	].

	tokens isEmpty ifTrue: [^ 'as yet unclassified'].
	^ String streamContents:
		[ :s |
		tokens
			do: [ :tok | s nextPutAll: tok ]
			separatedBy: [ s nextPut: $- ]]!

----- Method: PackageInfo>>category:matches: (in category 'testing') -----
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 ]) = $-!

----- Method: PackageInfo>>categoryName (in category 'naming') -----
categoryName
	|category|
	category := self class category.
	^ (category endsWith: '-Info')
		ifTrue: [category copyUpToLast: $-]
		ifFalse: [category]!

----- Method: PackageInfo>>changeRecordForOverriddenMethod: (in category 'testing') -----
changeRecordForOverriddenMethod: aMethodReference
	| sourceFilesCopy method position |
	method := aMethodReference actualClass compiledMethodAt: aMethodReference methodSymbol.
	position := method filePosition.
	sourceFilesCopy := SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	[ | file prevPos prevFileIndex chunk stamp methodCategory tokens |
	method fileIndex == 0 ifTrue: [^ nil].
	file := sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [chunk := file nextChunk].

		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos := nil.
		stamp := ''.
		(chunk findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens := Scanner new scanTokens: chunk]
			ifFalse: [tokens := Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp := tokens at: tokens size-2.
						prevPos := tokens last.
						prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]
				ifFalse: ["Old format gives no stamp; prior pointer in two parts"
						prevPos := tokens at: tokens size-2.
						prevFileIndex := tokens last].
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp := tokens at: tokens size]].
		methodCategory := tokens after: #methodsFor: ifAbsent: ['as yet unclassifed'].
		(self includesMethodCategory: methodCategory ofClass: aMethodReference actualClass) ifTrue:
			[methodCategory = (Smalltalk at: #Categorizer ifAbsent: [Smalltalk at: #ClassOrganizer]) default ifTrue: [methodCategory := methodCategory, ' '].
			^ ChangeRecord new file: file position: position type: #method
						class: aMethodReference classSymbol category: methodCategory meta: aMethodReference classIsMeta stamp: stamp].
		position := prevPos.
		prevPos notNil ifTrue:
			[file := sourceFilesCopy at: prevFileIndex]].
		^ nil]
			ensure: [sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]]
	!

----- Method: PackageInfo>>classes (in category 'listing') -----
classes
	^(self systemCategories gather:
		[:cat |
		(SystemOrganization listAtCategoryNamed: cat)
			collect: [:className | Smalltalk at: className]])
				sortBy: [:a :b | a className <= b className]!

----- Method: PackageInfo>>classesAndMetaClasses (in category 'listing') -----
classesAndMetaClasses
	"Return a Set with all classes and metaclasses belonging to this package"

	| baseClasses result |
	baseClasses := self classes.
	result := (Set new: baseClasses size * 2) 
		addAll: baseClasses;
		yourself.
	baseClasses do: [ :c | 
		result add: c classSide].
	^result
!

----- Method: PackageInfo>>coreCategoriesForClass: (in category 'testing') -----
coreCategoriesForClass: aClass
	^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]!

----- Method: PackageInfo>>coreMethods (in category 'listing') -----
coreMethods
	^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]!

----- Method: PackageInfo>>coreMethodsForClass: (in category 'testing') -----
coreMethodsForClass: aClass
	^ (aClass selectors difference:
		((self foreignExtensionMethodsForClass: aClass) collect: [:r | r methodSymbol]))
			asArray collect: [:sel | self referenceForMethod: sel ofClass: aClass]!

----- Method: PackageInfo>>extensionCategoriesForClass: (in category 'testing') -----
extensionCategoriesForClass: aClass
	^ aClass organization categories select: [:cat | self isYourClassExtension: cat]!

----- Method: PackageInfo>>extensionClasses (in category 'listing') -----
extensionClasses
	^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]!

----- Method: PackageInfo>>extensionMethods (in category 'listing') -----
extensionMethods
	^ self externalBehaviors gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]!

----- Method: PackageInfo>>extensionMethodsForClass: (in category 'testing') -----
extensionMethodsForClass: aClass
	^ (self extensionCategoriesForClass: aClass)
		gather: [:cat | self methodsInCategory: cat ofClass: aClass ]!

----- Method: PackageInfo>>extensionMethodsFromClasses: (in category 'testing') -----
extensionMethodsFromClasses: classes
	^classes
		gather: [:class | self extensionMethodsForClass: class]!

----- Method: PackageInfo>>externalBehaviors (in category 'modifying') -----
externalBehaviors
	^self externalClasses , self externalTraits!

----- Method: PackageInfo>>externalCallers (in category 'dependencies') -----
externalCallers
	^ self 
		externalRefsSelect: [:literal | literal isKindOf: Symbol] 
		thenCollect: [:l | l].!

----- Method: PackageInfo>>externalClasses (in category 'dependencies') -----
externalClasses
	| myClasses |
	myClasses := self classesAndMetaClasses.
	^ Array streamContents:
		[:s |
		ProtoObject withAllSubclassesDo:
			[:class |
			(myClasses includes: class) ifFalse: [s nextPut: class]]]!

----- Method: PackageInfo>>externalName (in category 'naming') -----
externalName
	^ self packageName!

----- Method: PackageInfo>>externalRefsSelect:thenCollect: (in category 'dependencies') -----
externalRefsSelect: selBlock thenCollect: colBlock
	| pkgMethods dependents extMethods otherClasses otherMethods classNames |

	classNames := self classes collect: [:c | c name].
	extMethods := self extensionMethods collect: [:mr | mr methodSymbol].
	otherClasses := self externalClasses difference: self externalSubclasses.
	otherMethods :=  otherClasses gather: [:c | c selectors].
	pkgMethods := self methods asSet collect: [:mr | mr methodSymbol].
	pkgMethods removeAllFoundIn: otherMethods.

	dependents := Set new.
	otherClasses do: [:c |
		c selectorsAndMethodsDo:
			[:sel :compiled |
			| refs |
			(extMethods includes: sel) ifFalse: 
				[refs := compiled literals select: selBlock thenCollect: colBlock.
				refs do: [:ea |
					((classNames includes: ea) or: [pkgMethods includes: ea])
							ifTrue: [dependents add: (self referenceForMethod: sel ofClass: c) -> ea]]]]].
	^ dependents!

----- Method: PackageInfo>>externalSubclasses (in category 'dependencies') -----
externalSubclasses
	| pkgClasses subClasses |
	pkgClasses := self classes.
	subClasses := Set new.
	pkgClasses do: [:c | subClasses addAll: (c allSubclasses)].
	^ subClasses difference: pkgClasses
!

----- Method: PackageInfo>>externalTraits (in category 'modifying') -----
externalTraits
	^ Array streamContents: [:s |
		| behaviors |
		behaviors := self classesAndMetaClasses.
		Smalltalk allTraits do: [:trait |
			(behaviors includes: trait) ifFalse: [s nextPut: trait].
			(behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]].			!

----- Method: PackageInfo>>externalUsers (in category 'dependencies') -----
externalUsers
	^ self 
		externalRefsSelect: [:literal | literal isVariableBinding] 
		thenCollect: [:l | l key]!

----- Method: PackageInfo>>foreignClasses (in category 'listing') -----
foreignClasses
	| s |
	s := IdentitySet new.
	self foreignSystemCategories
		do: [:c | (SystemOrganization listAtCategoryNamed: c)
				do: [:cl | 
					| cls | 
					cls := Smalltalk at: cl. 
					s add: cls;
					  add: cls class]].
	^ s!

----- Method: PackageInfo>>foreignExtensionCategoriesForClass: (in category 'testing') -----
foreignExtensionCategoriesForClass: aClass
	^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]!

----- Method: PackageInfo>>foreignExtensionMethodsForClass: (in category 'testing') -----
foreignExtensionMethodsForClass: aClass
	^ (self foreignExtensionCategoriesForClass: aClass)
		gather: [:cat | (aClass organization listAtCategoryNamed: cat)
						  collect: [:sel | self referenceForMethod: sel ofClass: aClass]]!

----- Method: PackageInfo>>foreignSystemCategories (in category 'listing') -----
foreignSystemCategories
	^ SystemOrganization categories
		reject: [:cat | self includesSystemCategory: cat] !

----- Method: PackageInfo>>hasPostscript (in category 'preamble/postscript') -----
hasPostscript

	^ postscript notNil!

----- Method: PackageInfo>>hasPostscriptOfRemoval (in category 'preamble/postscript') -----
hasPostscriptOfRemoval

	^ postscriptOfRemoval notNil!

----- Method: PackageInfo>>hasPreamble (in category 'preamble/postscript') -----
hasPreamble
	^ preamble notNil!

----- Method: PackageInfo>>hasPreambleOfRemoval (in category 'preamble/postscript') -----
hasPreambleOfRemoval

	^ preambleOfRemoval notNil!

----- Method: PackageInfo>>hash (in category 'comparing') -----
hash
	^ packageName hash!

----- Method: PackageInfo>>includesChangeRecord: (in category 'testing') -----
includesChangeRecord: aChangeRecord
	^ aChangeRecord methodClass notNil and:
		[self
			includesMethodCategory: aChangeRecord category
			ofClass: aChangeRecord methodClass]!

----- Method: PackageInfo>>includesClass: (in category 'testing') -----
includesClass: aClass
	^ self includesSystemCategory: aClass theNonMetaClass category!

----- Method: PackageInfo>>includesClassNamed: (in category 'testing') -----
includesClassNamed: aClassName
	^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])!

----- Method: PackageInfo>>includesMethod:ofClass: (in category 'testing') -----
includesMethod: aSymbol ofClass: aClass
	aClass ifNil: [^ false].
	^ self
		includesMethodCategory: ((aClass organization categoryOfElement: aSymbol)
										ifNil: [' '])
		ofClass: aClass!

----- Method: PackageInfo>>includesMethodCategory:ofClass: (in category 'testing') -----
includesMethodCategory: categoryName ofClass: aClass
	^ (self isYourClassExtension: categoryName)
		or: [(self includesClass: aClass)
				and: [(self isForeignClassExtension: categoryName) not]]!

----- Method: PackageInfo>>includesMethodCategory:ofClassNamed: (in category 'testing') -----
includesMethodCategory: categoryName ofClassNamed: aClass
	^ (self isYourClassExtension: categoryName)
		or: [(self includesClassNamed: aClass)
				and: [(self isForeignClassExtension: categoryName) not]]!

----- Method: PackageInfo>>includesMethodReference: (in category 'testing') -----
includesMethodReference: aMethodRef
	^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass!

----- Method: PackageInfo>>includesSystemCategory: (in category 'testing') -----
includesSystemCategory: categoryName
	^ self category: categoryName matches: self systemCategoryPrefix!

----- Method: PackageInfo>>isForeignClassExtension: (in category 'testing') -----
isForeignClassExtension: categoryName
	^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]!

----- Method: PackageInfo>>isOverrideCategory: (in category 'testing') -----
isOverrideCategory: aString
	^ aString endsWith: '-override'!

----- Method: PackageInfo>>isOverrideMethod: (in category 'testing') -----
isOverrideMethod: aMethodReference
	^ self isOverrideCategory: aMethodReference category!

----- Method: PackageInfo>>isOverrideOfYourMethod: (in category 'testing') -----
isOverrideOfYourMethod: aMethodReference
	"Answers true if the argument overrides a method in this package"
	^ (self isYourClassExtension: aMethodReference category) not and:
		[(self changeRecordForOverriddenMethod: aMethodReference) notNil]!

----- Method: PackageInfo>>isYourClassExtension: (in category 'testing') -----
isYourClassExtension: categoryName
	^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]!

----- Method: PackageInfo>>linesOfCode (in category 'source code management') -----
linesOfCode
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."
	^self methods inject: 0 into: [:sum :each | sum + each compiledMethod linesOfCode]!

----- Method: PackageInfo>>methodCategoryPrefix (in category 'naming') -----
methodCategoryPrefix
	^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]!

----- Method: PackageInfo>>methods (in category 'listing') -----
methods
	^ (self extensionMethods, self coreMethods) select: [:method |
		method isValid
			and: [method isLocalSelector
			and: [method methodSymbol isDoIt not]]]!

----- Method: PackageInfo>>methodsInCategory:ofClass: (in category 'testing') -----
methodsInCategory: aString ofClass: aClass 
	^Array streamContents: [:stream |
		self methodsInCategory: aString ofClass: aClass 
			do: [:each | stream nextPut: each]]
!

----- Method: PackageInfo>>methodsInCategory:ofClass:do: (in category 'enumerating') -----
methodsInCategory: aString ofClass: aClass do: aBlock
	((aClass organization listAtCategoryNamed: aString) ifNil: [^self])
		do: [:sel | aBlock value: (self referenceForMethod: sel ofClass: aClass)]!

----- Method: PackageInfo>>name (in category 'preamble/postscript') -----
name

^ self packageName!

----- Method: PackageInfo>>outsideClasses (in category 'testing') -----
outsideClasses
	^ProtoObject withAllSubclasses asSet difference: self classesAndMetaClasses!

----- Method: PackageInfo>>overriddenMethods (in category 'listing') -----
overriddenMethods
	^ Array streamContents: [:stream |
		self overriddenMethodsDo: [:each | stream nextPut: each]]
!

----- Method: PackageInfo>>overriddenMethodsDo: (in category 'enumerating') -----
overriddenMethodsDo: aBlock
	"Enumerates the methods the receiver contains which have been overridden by other packages"
	^ self allOverriddenMethodsDo: [:ea |
		(self isOverrideOfYourMethod: ea)
			ifTrue: [aBlock value: ea]]!

----- Method: PackageInfo>>overriddenMethodsInClass: (in category 'listing') -----
overriddenMethodsInClass: aClass
	^Array streamContents: [:stream |
		self overriddenMethodsInClass: aClass
			do: [:each | stream nextPut: each]]
!

----- Method: PackageInfo>>overriddenMethodsInClass:do: (in category 'enumerating') -----
overriddenMethodsInClass: aClass do: aBlock
	"Evaluates aBlock with the overridden methods in aClass"
	^ self overrideCategoriesForClass: aClass do: [:cat |
		self methodsInCategory: cat ofClass: aClass do: aBlock]!

----- Method: PackageInfo>>overrideCategoriesForClass: (in category 'testing') -----
overrideCategoriesForClass: aClass
	^Array streamContents: [:stream |
		self overrideCategoriesForClass: aClass
			do: [:each | stream nextPut: each]]
!

----- Method: PackageInfo>>overrideCategoriesForClass:do: (in category 'enumerating') -----
overrideCategoriesForClass: aClass do: aBlock
	"Evaluates aBlock with all the *foo-override categories in aClass"
	^ aClass organization categories do: [:cat |
		(self isOverrideCategory: cat) ifTrue: [aBlock value: cat]]!

----- Method: PackageInfo>>overrideMethods (in category 'listing') -----
overrideMethods
	^ self extensionMethods select: [:ea | self isOverrideMethod: ea]!

----- Method: PackageInfo>>packageName (in category 'naming') -----
packageName
	^ packageName ifNil: [packageName := self categoryName]!

----- Method: PackageInfo>>packageName: (in category 'naming') -----
packageName: aString
	packageName := aString!

----- Method: PackageInfo>>postscript (in category 'preamble/postscript') -----
postscript

^ postscript ifNil: [postscript := StringHolder new contents: '"below, add code to be run after the loading of this package"'].!

----- Method: PackageInfo>>postscript: (in category 'preamble/postscript') -----
postscript: aString

postscript := StringHolder new contents: aString!

----- Method: PackageInfo>>postscriptOfRemoval (in category 'preamble/postscript') -----
postscriptOfRemoval

^ postscriptOfRemoval ifNil: [postscriptOfRemoval := StringHolder new contents: '"below, add code to clean up after the unloading of this package"']!

----- Method: PackageInfo>>postscriptOfRemoval: (in category 'preamble/postscript') -----
postscriptOfRemoval: aString

postscriptOfRemoval := StringHolder new contents: aString
!

----- Method: PackageInfo>>preamble (in category 'preamble/postscript') -----
preamble

	^ preamble ifNil: [preamble := StringHolder new contents: '"below, add code to be run before the loading of this package"'].
!

----- Method: PackageInfo>>preamble: (in category 'preamble/postscript') -----
preamble: aString

preamble := StringHolder new contents: aString!

----- Method: PackageInfo>>preambleOfRemoval (in category 'preamble/postscript') -----
preambleOfRemoval

^ preambleOfRemoval ifNil: [preambleOfRemoval := StringHolder new contents: '"below, add code to prepare for the unloading of this package"']!

----- Method: PackageInfo>>preambleOfRemoval: (in category 'preamble/postscript') -----
preambleOfRemoval: aString

preambleOfRemoval := StringHolder new contents: aString
!

----- Method: PackageInfo>>printOn: (in category 'printing') -----
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self packageName;
		nextPut: $)!

----- Method: PackageInfo>>referenceForMethod:ofClass: (in category 'testing') -----
referenceForMethod: aSymbol ofClass: aClass
	^ MethodReference new setStandardClass: aClass methodSymbol: aSymbol!

----- Method: PackageInfo>>register (in category 'registering') -----
register
	PackageOrganizer default registerPackage: self!

----- Method: PackageInfo>>removeMethod: (in category 'modifying') -----
removeMethod: aMethodReference!

----- Method: PackageInfo>>selectors (in category 'listing') -----
selectors
	^ self methods collect: [:ea | ea methodSymbol]!

----- Method: PackageInfo>>systemCategories (in category 'listing') -----
systemCategories
	^ SystemOrganization categories select: [:cat | self includesSystemCategory: cat]!

----- Method: PackageInfo>>systemCategoryPrefix (in category 'naming') -----
systemCategoryPrefix
	^ self packageName!

Object subclass: #PackageList
	instanceVariableNames: 'selectedPackage packages'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PackageInfo-Base'!

----- Method: PackageList class>>initialize (in category 'as yet unclassified') -----
initialize
	TheWorldMenu registerOpenCommand: {'Package List'. {self. #open}}!

----- Method: PackageList class>>open (in category 'as yet unclassified') -----
open
	^ self new openInWorld!

----- Method: PackageList>>addPackage (in category 'actions') -----
addPackage
	| packageName |
	packageName := UIManager default request: 'Package name:'.
	packageName isEmpty ifFalse:
		[selectedPackage := self packageOrganizer registerPackageNamed: packageName.
		self changed: #packageSelection]!

----- Method: PackageList>>buildList (in category 'morphic') -----
buildList
	^ PluggableListMorph
		on: self
		list: #packageList
		selected: #packageSelection
		changeSelected: #packageSelection:
		menu: #packageMenu:!

----- Method: PackageList>>buildWindow (in category 'morphic') -----
buildWindow
	| window |
	window := SystemWindow labelled: self label.
	window model: self.
	window addMorph: self buildList fullFrame: (LayoutFrame fractions: (0 at 0 corner: 1 at 1)).
	^ window!

----- Method: PackageList>>defaultBackgroundColor (in category 'morphic') -----
defaultBackgroundColor 
	^ Color white!

----- Method: PackageList>>defaultExtent (in category 'morphic') -----
defaultExtent
	^ 200 at 200!

----- Method: PackageList>>label (in category 'morphic') -----
label
	^ 'Packages'!

----- Method: PackageList>>openInWorld (in category 'morphic') -----
openInWorld
	self packageOrganizer addDependent: self.
	self buildWindow openInWorldExtent: self defaultExtent!

----- Method: PackageList>>packageContextMenu: (in category 'morphic') -----
packageContextMenu: aMenu
	aMenu
		addLine;
		add: 'remove package' action: #removePackage;
		addServices: PackageServices allServices for: selectedPackage extraLines: #()!

----- Method: PackageList>>packageList (in category 'morphic') -----
packageList
	^ self packages collect: [:ea | ea packageName]!

----- Method: PackageList>>packageMenu: (in category 'morphic') -----
packageMenu: aMenu
	aMenu
		defaultTarget: self;
		add: 'add package' action: #addPackage.
	selectedPackage ifNotNil: [self packageContextMenu: aMenu].
	^ aMenu!

----- Method: PackageList>>packageOrganizer (in category 'actions') -----
packageOrganizer
	^ PackageOrganizer default!

----- Method: PackageList>>packageSelection (in category 'morphic') -----
packageSelection
	^ self packages indexOf: selectedPackage!

----- Method: PackageList>>packageSelection: (in category 'morphic') -----
packageSelection: aNumber
	selectedPackage := self packages at: aNumber ifAbsent: [].
	self changed: #packageSelection!

----- Method: PackageList>>packages (in category 'as yet unclassified') -----
packages
	^ packages ifNil: [packages := self packageOrganizer packages asSortedCollection:
									[:a :b | a packageName <= b packageName]]!

----- Method: PackageList>>perform:orSendTo: (in category 'morphic') -----
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]!

----- Method: PackageList>>removePackage (in category 'actions') -----
removePackage
	self packageOrganizer unregisterPackage: selectedPackage!

----- Method: PackageList>>update: (in category 'actions') -----
update: aSymbol
	aSymbol = #packages ifTrue:
		[packages := nil.
		self changed: #packageList; changed: #packageSelection]!

Object subclass: #PackageOrganizer
	instanceVariableNames: 'packages'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PackageInfo-Base'!
PackageOrganizer class
	instanceVariableNames: 'default'!
PackageOrganizer class
	instanceVariableNames: 'default'!

----- Method: PackageOrganizer class>>default (in category 'as yet unclassified') -----
default
	^ default ifNil: [default := self new]!

----- Method: PackageOrganizer class>>new (in category 'as yet unclassified') -----
new
	^ self basicNew initialize!

----- Method: PackageOrganizer>>initialize (in category 'initializing') -----
initialize
	packages := Dictionary new!

----- Method: PackageOrganizer>>noPackageFound (in category 'searching') -----
noPackageFound
	self error: 'No package found'!

----- Method: PackageOrganizer>>packageNamed:ifAbsent: (in category 'searching') -----
packageNamed: aString ifAbsent: errorBlock
	^ packages at: aString ifAbsent: errorBlock!

----- Method: PackageOrganizer>>packageNames (in category 'accessing') -----
packageNames
	^ packages keys!

----- Method: PackageOrganizer>>packageOfClass: (in category 'searching') -----
packageOfClass: aClass
	^ self packageOfClass: aClass ifNone: [self noPackageFound]!

----- Method: PackageOrganizer>>packageOfClass:ifNone: (in category 'searching') -----
packageOfClass: aClass ifNone: errorBlock
	^ self packages detect: [:ea | ea includesClass: aClass] ifNone: errorBlock!

----- Method: PackageOrganizer>>packageOfMethod: (in category 'searching') -----
packageOfMethod: aMethodReference
	^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]!

----- Method: PackageOrganizer>>packageOfMethod:ifNone: (in category 'searching') -----
packageOfMethod: aMethodReference ifNone: errorBlock
	^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock!

----- Method: PackageOrganizer>>packageOfMethodCategory:ofClass: (in category 'searching') -----
packageOfMethodCategory: categoryName ofClass: aClass
	^self packageOfMethodCategory: categoryName ofClass: aClass ifNone: [ self noPackageFound ]
!

----- Method: PackageOrganizer>>packageOfMethodCategory:ofClass:ifNone: (in category 'searching') -----
packageOfMethodCategory: categoryName ofClass: aClass ifNone: errorBlock
	^ self packages detect: [:ea | ea includesMethodCategory: categoryName ofClassNamed: aClass] ifNone: errorBlock
	
	
!

----- Method: PackageOrganizer>>packageOfSystemCategory: (in category 'searching') -----
packageOfSystemCategory: aSystemCategory
	^ self packageOfSystemCategory: aSystemCategory ifNone: [ self noPackageFound ]
!

----- Method: PackageOrganizer>>packageOfSystemCategory:ifNone: (in category 'searching') -----
packageOfSystemCategory: aSystemCategory ifNone: errorBlock
	^ self packages detect: [:ea | ea includesSystemCategory: aSystemCategory] ifNone: errorBlock
!

----- Method: PackageOrganizer>>packages (in category 'accessing') -----
packages
	^ packages values!

----- Method: PackageOrganizer>>registerPackage: (in category 'registering') -----
registerPackage: aPackageInfo
	packages at: aPackageInfo packageName put: aPackageInfo.
	self changed: #packages; changed: #packageNames.
!

----- Method: PackageOrganizer>>registerPackageNamed: (in category 'registering') -----
registerPackageNamed: aString
	^ self registerPackage: (PackageInfo named: aString)!

----- Method: PackageOrganizer>>unregisterPackage: (in category 'registering') -----
unregisterPackage: aPackageInfo
	packages removeKey: aPackageInfo packageName ifAbsent: [].	
	self changed: #packages; changed: #packageNames.
!

----- Method: PackageOrganizer>>unregisterPackageNamed: (in category 'registering') -----
unregisterPackageNamed: aString
	self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])!

Object subclass: #PackageServices
	instanceVariableNames: ''
	classVariableNames: 'ServiceClasses'
	poolDictionaries: ''
	category: 'PackageInfo-Base'!

----- Method: PackageServices class>>allServices (in category 'as yet unclassified') -----
allServices
	^ ServiceClasses gather: [:ea | ea services]!

----- Method: PackageServices class>>initialize (in category 'as yet unclassified') -----
initialize
	ServiceClasses := Set new!

----- Method: PackageServices class>>register: (in category 'as yet unclassified') -----
register: aClass
	ServiceClasses add: aClass!

----- Method: PackageServices class>>unregister: (in category 'as yet unclassified') -----
unregister: aClass
	ServiceClasses remove: aClass!

----- Method: PositionableStream>>untilEnd:displayingProgress: (in category '*packageinfo-base') -----
untilEnd: aBlock displayingProgress: aString
	aString
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
			[:bar |
			[self atEnd] whileFalse:
				[bar value: self position.
				aBlock value]].!

----- Method: String>>escapeEntities (in category '*packageinfo-base') -----
escapeEntities
	^ self species streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]]
!