'8/27/00 8:46:33 am'!

Object subclass: #ParcelEnhancements
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Goodies-Misc'!


Object subclass: #ParcelEnhancements
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Goodies-Misc'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ParcelEnhancements class
	instanceVariableNames: ''!


!ParcelEnhancements class methodsFor: 'copyright'!

copyright
	^'Copyleft 1999 NISHIHARA Satoshi.'!

system
	^'Goodies'!

version
	^'001'! !

!ParcelEnhancements class methodsFor: 'class initialization'!

induct
	"ParcelEnhancements induct."

	self ensureLoadedParcelWithVersionForInParcelClass!

initialize
	"ParcelEnhancements initialize."

	self install!

install
	"ParcelEnhancements install."

	| default done process count |
	(ObjectMemory versionId at: 5) < 30 ifTrue: [^nil].
	Cursor normal show.
	default := false.
	done := false.
	process := 
			[default := Dialog confirm: 'Do you want to enhance the Parcel loading?' initialAnswer: default.
			default ifTrue: [self induct].
			done := true] newProcess.
	process priority: Processor activeProcess priority + 0.
	process resume.
	count := 0.
	[done not and: [count < 10]]
		whileTrue: 
			[count := count + 1.
			(Delay forSeconds: 1) wait].
	process terminate.
	done ifFalse: [default ifTrue: [self induct]]!

obsolete
	self uninduct.
	super obsolete!

uninduct
	"ParcelEnhancements uninduct."

	| aClass aSelector |
	enhancements notNil
		ifTrue: 
			[enhancements copy
				do: 
					[:anArray | 
					aClass := Compiler evaluate: (anArray at: 1)
								logged: false.
					aSelector := anArray at: 3.
					self uninstallEnhanceClass: aClass selector: aSelector].
			enhancements := nil]!

uninstall
	"ParcelEnhancements uninstall."

	self uninduct! !

!ParcelEnhancements class methodsFor: 'enhancements'!

ensureLoadedParcelWithVersionForInParcelClass
	"ParcelEnhancements ensureLoadedParcelWithVersionForInParcelClass."

	self
		installEnhanceClass: Parcel class
		protocol: 'private-loading'
		code: 'ensureLoadedParcel: parcelName withVersion: versionString for: codeReaderOrNil
	"Check if a Parcel named parcelName is loaded with an appropriate version.
	 If its not then attempt to load it.  If codeReaderOrNil is non-nil then substitute
	 codeReaderOrNil streamDirectory for `current directory'' in the SearchPath
	 directory list."

	| aDirectoryOrNil parcel dirs found |
	aDirectoryOrNil := codeReaderOrNil == nil ifFalse:
							[codeReaderOrNil streamDirectory].
	"If the parcel is already loaded check its version and bail if its not acceptable."
	nil ~~ (parcel := self parcelNamed: parcelName) ifTrue:
		[(codeReaderOrNil == nil
		or: [codeReaderOrNil
				checkPrerequisiteNamed: parcelName
				withVersion: (parcel propertyAt: #version ifAbsent: [''''])
				requiredVersion: versionString]) ifFalse:
			[CodeReader incompatibleVersionIdSignal
				raiseRequestWith: (Array with: parcelName with: versionString)].
		^parcel].

	dirs := OrderedCollection withAll: self searchPathModel value.
	"If aDirectoryOrNil notNil include it after the list."
	aDirectoryOrNil notNil ifTrue: [dirs addLast: aDirectoryOrNil asLogicalFileSpecification].
	"As a last resort include the current directory."
	dirs addLast: Filename currentDirectory.

	found := false.

	1 to: dirs size do:
		[:i| | dirName dir |
		dirName := dirs at: i.
		"map the current directory onto the supplied current directory if dirName is dot
		 and we''re not searching the current directory."
		(dir := ((dirName asString = Filename defaultClass currentDirectoryString)
				and: [i < dirs size])
					ifTrue: [aDirectoryOrNil]
					ifFalse: [dirName]) notNil ifTrue:
			[self cachedParcelFileInfoIn: dir asLogicalFileSpecification for: parcelName do:
				[:info :filename|
				found := found or: [parcelName = (info at: #parcel)].
				(parcelName = (info at: #parcel)
				and: [codeReaderOrNil == nil
					   or: [codeReaderOrNil
							checkPrerequisiteNamed: parcelName
							withVersion: (info at: #version ifAbsent: [''''])
							requiredVersion: versionString]]) ifTrue:
					[| versionStringOfInfo |
					versionStringOfInfo := info at: #version ifAbsent: [String new].
					(versionString isEmpty or: [versionString = versionStringOfInfo or: [(versionStringOfInfo indexOfSubCollection: versionString startingAt: 1)
								> 0 or: [(versionString indexOfSubCollection: versionStringOfInfo startingAt: 1)
									> 0]]]) 
						ifTrue: 
							[Transcript
								cr; nextPutAll: ''Autoloading ''; nextPutAll: parcelName;
								nextPutAll: '' from ''; nextPutAll: filename asString; endEntry.
							^self loadParcelCachedFrom: filename]]]]].
	found ifTrue:
		[CodeReader incompatibleVersionIdSignal
			raiseRequestWith: (Array with: parcelName with: versionString)].

	^Parcel missingParcelSignal raiseRequestWith: parcelName'! !

!ParcelEnhancements class methodsFor: 'saving'!

save
	"ParcelEnhancements save."

	| encodingName fileName classCollection aStream |
	encodingName := #default.
	fileName := 'ParcelEn.st'.
	classCollection := self saveClasses.
	aStream := (fileName asFilename withEncoding: encodingName) writeStream.
	[Cursor write
		showWhile: 
			[| timeStamp |
			timeStamp := Date today shortPrintString , ' ' , Time now shortPrintString.
			aStream cr.
			aStream nextChunkPut: timeStamp printString.
			aStream cr; cr.
			(self comment isNil or: [self comment isEmpty])
				ifFalse: 
					[aStream nextChunkPut: self comment printString.
					aStream cr; cr].
			classCollection
				do: 
					[:aClass | 
					aStream nextChunkPut: aClass definition.
					aStream cr; cr].
			classCollection
				do: 
					[:aClass | 
					| sourceCodeStream |
					aStream nextPut: Character newPage.
					aStream cr.
					sourceCodeStream := SourceCodeStream on: aStream.
					aClass fileOutSourceOn: sourceCodeStream.
					aStream cr]]]
		valueNowOrOnUnwindDo: [aStream close].
	^classCollection!

saveClasses
	"ParcelEnhancements saveClasses."

	| patternCollection classCollection |
	patternCollection := #('*ParcelEnhancements*').
	classCollection := Smalltalk organization superclassOrder: self category.
	classCollection := classCollection
				select: 
					[:aClass | 
					| string something |
					string := aClass name asString.
					something := patternCollection detect: [:it | it match: string]
								ifNone: [nil].
					something notNil].
	^classCollection! !

!ParcelEnhancements class methodsFor: 'private'!

installEnhanceClass: aClass protocol: aProtocol code: aCode 
	| aSelector anArray oldCode aCategory |
	aClass isBehavior ifFalse: [^self].
	aSelector := Parser new parseSelector: aCode.
	aSelector isNil ifTrue: [^self].
	enhancements isNil ifTrue: [enhancements := OrderedCollection new].
	anArray := enhancements
				detect: 
					[:array | 
					| bool |
					bool := aClass name asString = (array at: 1).
					bool := bool and: [aSelector = (array at: 3)].
					bool yourself]
				ifNone: [nil].
	anArray isNil
		ifTrue: 
			[(aClass includesSelector: aSelector)
				ifTrue: 
					[oldCode := aClass sourceCodeAt: aSelector.
					aCategory := aClass organization categoryOfElement: aSelector.
					aCategory isNil ifTrue: [aCategory := #undefined]]
				ifFalse: 
					[oldCode := nil.
					aCategory := aProtocol].
			enhancements add: (Array
					with: aClass name asString
					with: aCategory asString
					with: aSelector
					with: oldCode)].
	aClass compile: aCode classified: aProtocol!

uninstallEnhanceClass: aClass selector: aSelector 
	| anArray aProtocol oldCode |
	aClass isBehavior ifFalse: [^self].
	(aSelector isKindOf: Symbol)
		ifFalse: [^self].
	enhancements isNil ifTrue: [^self].
	anArray := enhancements
				detect: 
					[:array | 
					| bool |
					bool := aClass name asString = (array at: 1).
					bool := bool and: [aSelector = (array at: 3)].
					bool yourself]
				ifNone: [nil].
	anArray isNil ifTrue: [^self].
	aProtocol := anArray at: 2.
	oldCode := anArray at: 4.
	oldCode isNil
		ifTrue: ["remove method"
			aClass removeSelector: aSelector]
		ifFalse: ["restore method"
			aClass compile: oldCode classified: aProtocol].
	enhancements remove: anArray! !

ParcelEnhancements initialize!