'From etoys3.0 of 24 February 2008 [latest update: #1951] on 28 March 2008 at 8:45:37 pm'!
"Change Set:		ProjectLoadingMar28-yo
Date:			28 March 2008
Author:			Yoshiki Ohshima

Some optimizations on ProjectLoading.

  To measure stuff, following might be useful.

dir _ FileDirectory on: 'C:\squeak\olpc\ExampleEtoysSISS'.
entries _ FileList2 projectOnlySelectionMethod: dir entries.
entries _ entries collect: [:each | Project parseProjectFileName: each first].
entries do: [:each |
	Transcript show: '\siss: ' withCRs, each first, ' ', ([ProjectLoading loadFromDir: 'C:\squeak\olpc\ExampleEtoysSISS' projectName: each first] timeToRun) printString.
	proj _ (Project named: each first).
	proj ifNotNil: [proj okToChangeSilently].
	Transcript show: '\classic: ' withCRs , each first, ' ', ([ProjectLoading loadFromDir: 'C:\squeak\olpc\ExampleEtoys' projectName: each first] timeToRun) printString.
	Transcript cr.
	proj _ (Project named: each first).
	proj ifNotNil: [proj okToChangeSilently].
].

	MessageTally spyOn: [ProjectLoading loadFromDir: 'C:\squeak\olpc\ExampleEtoys' projectName: 'DemonCastle1'].
"!


!ImageSegment methodsFor: 'fileIn/Out' stamp: 'yo 3/28/2008 20:44'!
comeFullyUpOnReload: smartRefStream
	"fix up the objects in the segment that changed size.  An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size.  Replace the modern class with the old one in outPointers.  Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages.  Keep the new instances.  Bulk forward become the old to the new.  Let go of the fake objects and classes.
	After the install (below), arrayOfRoots is filled in. Globalize new classes.  Caller may want to do some special install on certain objects in arrayOfRoots.
	May want to write the segment out to disk in its new form."

	| mapFakeClassesToReal ccFixups receiverClasses rootsToUnhiberhate myProject existing |

	RecentlyRenamedClasses _ nil.		"in case old data hanging around"
	mapFakeClassesToReal _ smartRefStream reshapedClassesIn: outPointers.
		"Dictionary of just the ones that change shape. Substitute them in outPointers."
	ccFixups _ self remapCompactClasses: mapFakeClassesToReal
				refStrm: smartRefStream.
	ccFixups ifFalse: [^ self error: 'A class in the file is not compatible'].
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
	self fixCapitalizationOfSymbols.
	arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers.
		"Can't use install.  Not ready for rehashSets"
	mapFakeClassesToReal isEmpty ifFalse: [
		self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
	].
	"When a Project is stored, arrayOfRoots has all objects in the project, except those in outPointers"
	arrayOfRoots do: [:importedObject |
		((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [
			importedObject mutateJISX0208StringToUnicode.
			importedObject class = WideSymbol ifTrue: [
				"self halt."
				Symbol hasInterned: importedObject asString ifTrue: [:multiSymbol |
					multiSymbol == importedObject ifFalse: [
						importedObject becomeForward: multiSymbol.
					].
				].
			].
		].
		(importedObject isMemberOf: TTCFontSet) ifTrue: [
			existing _ TTCFontSet familyName: importedObject familyName
						pointSize: importedObject pointSize.	"supplies default"
			existing == importedObject ifFalse: [importedObject becomeForward: existing].
		].
	].

	receiverClasses _ self restoreEndianness.		"rehash sets"
	smartRefStream checkFatalReshape: receiverClasses.

	"Classes in this segment."
	arrayOfRoots do: [:importedObject |
		importedObject class class == Metaclass ifTrue: [self declare: importedObject]].
	rootsToUnhiberhate := OrderedCollection new.
	arrayOfRoots do: [:importedObject |
		((importedObject isMemberOf: ScriptEditorMorph)
			or: [(importedObject isKindOf: TileMorph)
				or: [(importedObject isKindOf: TileMorph)
					or: [importedObject isKindOf: CompoundTileMorph]]]) ifTrue: [
				
			rootsToUnhiberhate add: importedObject
		].
		(importedObject isMemberOf: CompiledMethod) ifTrue: [
			importedObject sourcePointer > 0 ifTrue: [importedObject zapSourcePointer]].
		(importedObject isMemberOf: Project) ifTrue: [
			myProject _ importedObject.
			importedObject ensureChangeSetNameUnique.
			Project addingProject: importedObject.
			importedObject restoreReferences.
			self dependentsRestore: importedObject.
			ScriptEditorMorph writingUniversalTiles:
				((importedObject projectPreferenceAt: #universalTiles) ifNil: [false])]].

	myProject ifNotNil: [
		myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray.
	].

	mapFakeClassesToReal isEmpty ifFalse: [
		mapFakeClassesToReal keys do: [:aFake |
			aFake indexIfCompact > 0 ifTrue: [aFake becomeUncompact].
			aFake removeFromSystemUnlogged].
		SystemOrganization removeEmptyCategories].
	"^ self"
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'yo 3/28/2008 20:07'!
restoreEndianness
	"Fix endianness (byte order) of any objects not already fixed.  Do this by discovering classes that need a startUp message sent to each instance, and sending it.
	I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
	Also, collect all classes of receivers of blocks which refer to instance variables.  Return them.  Caller will check if they have been reshaped."

	| object sets receiverClasses inSeg noStartUpNeeded startUps cls msg methodDictionaries |

	object _ segment.
	sets _ OrderedCollection new.
		"have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
	receiverClasses _ IdentitySet new.
	noStartUpNeeded _ IdentitySet new.	"classes that don't have a per-instance startUp message"
	startUps _ IdentityDictionary new.	"class -> MessageSend of a startUp message"
	inSeg _ true.
	[object _ object nextObject.  "all the way to the end of memory to catch remade objects"
		object == endMarker ifTrue: [inSeg _ false].	"off end"
		object isInMemory ifTrue: [
			(object isKindOf: Set) ifTrue: [sets add: object].
			(object isKindOf: ContextPart) ifTrue: [
				(inSeg and: [object hasInstVarRef]) ifTrue: [
					receiverClasses add: object receiver class]].
			inSeg ifTrue: [
				(noStartUpNeeded includes: object class) ifFalse: [
					cls _ object class.
					(msg _ startUps at: cls ifAbsent: [nil]) ifNil: [
						msg _ cls startUpFrom: self.	"a Message, if we need to swap bytes this time"
						msg ifNil: [noStartUpNeeded add: cls]
							ifNotNil: [startUps at: cls put: msg]].
					msg ifNotNil: [msg sentTo: object]]]]. 
		object == 0] whileFalse.
	methodDictionaries := sets select: [:s | s isMemberOf: MethodDictionary].
	sets removeAllSuchThat: [:s | s isMemberOf: MethodDictionary].
	self rehashDictionaries: sets. "our purpose"
	self rehashMethodDictionaries: methodDictionaries.
	^ receiverClasses	"our secondary job"
! !


!InflateStream methodsFor: 'accessing' stamp: 'yo 3/28/2008 19:57'!
upToEndWithProgressBar
	"#upToEnd with progress bar version"
	| newStream buffer size |
	size := sourceStream size.
	ProgressInitiationException
		display: 'Unzip a stream' translated
		during: [:bar | 
			buffer := collection species new: 1000.
			newStream := WriteStream
						on: (collection species new: 100).
			[self atEnd]
				whileFalse: [newStream
						nextPutAll: (self nextInto: buffer).
					bar value: (sourceStream position // size) asFloat]].
	^ newStream contents! !


!Project methodsFor: 'menu messages' stamp: 'yo 3/28/2008 20:36'!
finalEnterActions
	"Perform the final actions necessary as the receiver project is entered"

	| navigator armsLengthCmd navType thingsToUnhibernate |

	self projectParameters 
		at: #projectsToBeDeleted 
		ifPresent: [ :projectsToBeDeleted |
			self removeParameter: #projectsToBeDeleted.
			projectsToBeDeleted do: [ :each | 
				Project deletingProject: each.
				each removeChangeSetIfPossible]].

	Preferences preserveProjectLocale
		ifTrue: [Locale switchAndInstallFontToID: self localeID gently: true]
		ifFalse: [self localeID = LocaleID current ifFalse: [self localeChanged]].

	thingsToUnhibernate _ world valueOfProperty: #thingsToUnhibernate ifAbsent: [#()].
	thingsToUnhibernate do: [:each | each unhibernate].
	world removeProperty: #thingsToUnhibernate.

	(self projectParameterAt: #substitutedFont) ifNotNil: [
		self removeParameter: #substitutedFont.
		self world presenter allPlayersWithUniclasses do: [:uni | uni allScriptEditors do: [:scr |
			scr setProperty: #needsLayoutFixed toValue: true ]].
	].

	navType _ ProjectNavigationMorph preferredNavigator.
	armsLengthCmd _ self parameterAt: #armsLengthCmd ifAbsent: [nil].
	navigator _ world findA: navType.
	(Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator and: [navigator isNil]]) ifTrue:
		[(navigator _ navType new addButtons)
			bottomLeft: world bottomLeft;
			openInWorld: world].
	navigator notNil & armsLengthCmd notNil ifTrue:
		[navigator color: Color lightBlue. navigator inspect.].
	armsLengthCmd ifNotNil: [armsLengthCmd openInWorld: world].
	Smalltalk isMorphic ifTrue:
		[world reformulateUpdatingMenus.
		world presenter positionStandardPlayer].

	WorldState addDeferredUIMessage: [self startResourceLoading].! !


!ProjectLoading class methodsFor: 'public' stamp: 'yo 3/28/2008 18:51'!
loadFromDir: dirName projectName: projectName 
	"Open the project in image path. This is used with projects in OLPC distribution.
	- The image's directory is used.
	- Squeaklets directory is ignored.
	- If there is a project named projectName, it is opened.
	"
	"self openFromImagePath: 'Welcome'"
	| directory aStream entries fileName |
	(Project named: projectName)
		ifNotNilDo: [:project | ^ project].
	directory := FileDirectory on: dirName.
	entries := FileList2 projectOnlySelectionMethod: directory entries.
	entries := entries
				detect: [:each | (Project parseProjectFileName: each first) first = projectName] ifNone: [^ self].
	fileName := entries first.
	self
		showProgressBarDuring: [ProgressNotification signal: '0'.
			aStream := directory readOnlyFileNamed: fileName.
			self
				loadName: fileName
				stream: aStream
				fromDirectory: directory
				withProjectView: nil]! !

ViewerFlapTab removeSelector: #unhibernate!