'From etoys2.1 of 8 August 2007 [latest update: #1629] on 13 September 2007 at 12:06:11 am'!
"Change Set:		FeedbackWhileSaving-yo
Date:			13 September 2007
Author:			Yoshiki Ohshima

Give better feedback while automatically saving."!


!Project methodsFor: 'menu messages' stamp: 'yo 9/12/2007 23:30'!
displayProgressWithMessage:  aMessage
	"Answer a block to display progress while some time-consuming action is going on; the message provided is shown within a tableau of special chars.  This is basically Andreas's code."

	| done b pp |
	done := false.
	b := ScriptableButton new.
	b color: Color yellow.
	b borderWidth: 1; borderColor: Color black.
	pp := [	| dots str idx |
		dots := #(' - ' ' \ ' ' | ' ' / '). idx := 0.
		[done] whileFalse:[
			str _ aMessage.
			str := str copyReplaceTokens: '$' with: (dots atWrap: (idx := idx + 1)) asString.
			b label: str font: (Preferences standardEToysFont emphasized: 1).
			b extent: 200@50.
			b center: Display center.
			b fullDrawOn: Display getCanvas.
			(Delay forMilliseconds: 1000) wait.
		].
	] forkAt: Processor userInterruptPriority.
	^[done := true]! !

!Project methodsFor: 'menu messages' stamp: 'yo 9/12/2007 23:23'!
displaySavingProgress
	"Display progress for fonts"
	
	^ self displayProgressWithMessage: '$	Saving	$	' translated! !

!Project methodsFor: 'file in/out' stamp: 'yo 9/12/2007 23:42'!
armsLengthCommand: aCommand withDescription: aString
	| pvm tempProject foolingForm tempCanvas bbox crossHatchColor stride |
	"Set things up so that this aCommand is sent to self as a message
after jumping to the parentProject.  For things that can't be executed
while in this project, such as saveAs, loadFromServer, storeOnServer.  See
ProjectViewMorph step."

	self isMorphic ifTrue: [
		world borderWidth: 0.	"get rid of the silly default border"
		tempProject _ Project newMorphic.
		foolingForm _ world imageForm.		"make them think they never left"
		tempCanvas _ foolingForm getCanvas.
		bbox _ foolingForm boundingBox.
		crossHatchColor _ Color blue alpha: 0.3.
		stride _ 30.
		10 to: bbox width by: stride do: [ :x |
			tempCanvas fillRectangle: (x@0 extent: 2@bbox height) fillStyle: crossHatchColor.
		].
		10 to: bbox height by: stride do: [ :y |
			tempCanvas fillRectangle: (0@y extent: bbox width@2) fillStyle: crossHatchColor.
		].

		tempProject world color: (InfiniteForm with: foolingForm).
		tempProject projectParameters 
			at: #armsLengthCmd 
			put: (
				DoCommandOnceMorph new
					addText: aString;
					actionBlock: [
						self doArmsLengthCommand: aCommand.
					] fixTemps
			).
		tempProject projectParameters 
			at: #deleteWhenEnteringNewProject 
			put: true.
		tempProject enter.
	] ifFalse: [
		parentProject ifNil: [^ self inform: 'The top project can''t do that'].
		pvm _ parentProject findProjectView: self.
		pvm armsLengthCommand: {self. aCommand}.
		self exit.
	].
! !

!Project methodsFor: 'file in/out' stamp: 'yo 9/12/2007 23:29'!
storeOnServerWithNoInteraction

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."
	| ret pp |
	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self isCurrentProject ifTrue: ["exit, then do the command"
		Flaps globalFlapTabsIfAny do: [:each | Flaps removeFlapTab: each keepInList: true].
		ret _ self 
			armsLengthCommand: #storeOnServerWithNoInteraction
			withDescription: 'Publishing' translated.
		^ ret
	].
	pp _   self displaySavingProgress.
	[self storeOnServerWithNoInteractionInnards] on: Error do: [:ex | pp value. ^ false].
	pp value.
	^ true.
! !

!Project methodsFor: 'file in/out' stamp: 'yo 9/12/2007 23:29'!
storeOnServerWithNoInteractionThenQuit

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded. Then Quit"
	| ret pp |
	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self isCurrentProject ifTrue: ["exit, then do the command"
		Flaps globalFlapTabsIfAny do: [:each | Flaps removeFlapTab: each keepInList: true].
		ret _ self 
			armsLengthCommand: #storeOnServerWithNoInteractionThenQuit
			withDescription: 'Publishing' translated.
		^ ret
	].
	pp _   self displaySavingProgress.
	[[self storeOnServerWithNoInteractionInnards]
		on: Error do: [:ex |
			Smalltalk logError: ex description
				inContext: ex signalerContext
				to: 'SqueakDebug.log']
	] ensure: [pp value. Smalltalk quitPrimitive].
	^ true.
! !

!Project methodsFor: '*WS-Sound-Override' stamp: 'yo 9/13/2007 00:03'!
enter: returningFlag revert: revertFlag saveForRevert: saveForRevert
	"Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case.
	If saveForRevert is true, save the ImageSegment of the project being left.
	If revertFlag is true, make stubs for the world of the project being left.
	If revertWithoutAsking is true in the project being left, then always revert."

	| showZoom recorderOrNil old forceRevert response seg newProcess |

	SoundPlayer shutDown.
	(world isKindOf: StringMorph) ifTrue: [
		self inform: 'This project is not all here. I will try to load a complete version.' translated.
		^self loadFromServer: true	"try to get a fresh copy"
	].
	self isCurrentProject ifTrue: [^ self].
	"Check the guards"
	guards ifNotNil:
		[guards _ guards reject: [:obj | obj isNil].
		guards do: [:obj | obj okayToEnterProject ifFalse: [^ self]]].
	CurrentProject world triggerEvent: #aboutToLeaveWorld.
	forceRevert _ false.
	CurrentProject rawParameters 
		ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to' translated]]
		ifNotNil: [saveForRevert ifFalse: [
				forceRevert _ CurrentProject projectParameters 
								at: #revertWithoutAsking ifAbsent: [false]]].
	forceRevert not & revertFlag ifTrue: [
		response _ SelectionMenu confirm: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' translated withCRs
			trueChoice: 'Revert to saved version' translated
			falseChoice: 'Cancel' translated.
		response ifFalse: [^ self]].

	revertFlag | forceRevert 
		ifTrue: [seg _ CurrentProject projectParameters at: #revertToMe ifAbsent: [
					^ self inform: 'nothing to revert to' translated]]
		ifFalse: [
			CurrentProject finalExitActions.
			CurrentProject makeThumbnail.
			returningFlag == #specialReturn
				ifTrue:
					[ProjectHistory forget: CurrentProject.		"this guy is irrelevant"
					Project forget: CurrentProject]
				ifFalse:
					[ProjectHistory remember: CurrentProject]].

	(revertFlag | saveForRevert | forceRevert) ifFalse:
		[(Preferences valueOfFlag: #projectsSentToDisk) ifTrue:
			[self storeToMakeRoom]].

	CurrentProject abortResourceLoading.
	Smalltalk isMorphic ifTrue: [CurrentProject world triggerClosingScripts].

	CurrentProject saveProjectPreferences.

	"Update the display depth and make a thumbnail of the current project"
	CurrentProject displayDepth: Display depth.
	old _ CurrentProject.		"for later"

	"Show the project transition.
	Note: The project zoom is run in the context of the old project,
		so that eventual errors can be handled accordingly"
	displayDepth == nil ifTrue: [displayDepth _ Display depth].
	self installNewDisplay: Display extent depth: displayDepth.
	(showZoom _ self showZoom) ifTrue: [
		self displayZoom: CurrentProject parent ~~ self].

	(world isMorph and: [world hasProperty: #letTheMusicPlay])
		ifTrue: [world removeProperty: #letTheMusicPlay]
		ifFalse: [Smalltalk at: #ScorePlayer ifPresentAndInMemory:
					[:playerClass | playerClass allSubInstancesDo:
						[:player | player pause]]].

	returningFlag == #specialReturn ifTrue: [
		old removeChangeSetIfPossible.	"keep this stuff from accumulating"
		nextProject _ nil
	] ifFalse: [
		returningFlag
			ifTrue: [nextProject _ CurrentProject]
			ifFalse: [previousProject _ CurrentProject].
	].

	CurrentProject saveState.
	CurrentProject isolationHead == self isolationHead ifFalse:
		[self invokeFrom: CurrentProject].
	CurrentProject _ self.
	self installProjectPreferences.
	ChangeSet  newChanges: changeSet.
	TranscriptStream newTranscript: transcript.
	Sensor flushKeyboard.
	Smalltalk isMorphic ifTrue: [recorderOrNil _ World pauseEventRecorder].

	ProjectHistory remember: CurrentProject.

	world isMorph
		ifTrue:
			[World _ world.  "Signifies Morphic"
			self projectParameters  at: #armsLengthCmd ifPresent: [:param |
				self flapsSuppressed: true.
			].
			world install.
			world transferRemoteServerFrom: old world.
			"(revertFlag | saveForRevert | forceRevert) ifFalse: [
				(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
					self storeSomeSegment]]."
			recorderOrNil ifNotNil: [recorderOrNil resumeIn: world].
			world triggerOpeningScripts]
		ifFalse:
			[World _ nil.  "Signifies MVC"
			Smalltalk at: #ScheduledControllers put: world].

	saveForRevert ifTrue: [
		Smalltalk garbageCollect.	"let go of pointers"
		old storeSegment.
		"result _" old world isInMemory 
			ifTrue: ['Can''t seem to write the project.']
			ifFalse: [old projectParameters at: #revertToMe put: 
					old world xxxSegment clone].
				'Project written.'].
			"original is for coming back in and continuing."

	revertFlag | forceRevert ifTrue: [
		seg clone revert].	"non-cloned one is for reverting again later"
	self removeParameter: #exportState.

	"Complete the enter: by launching a new process"
	world isMorph ifTrue: [
		self finalEnterActions.
		world repairEmbeddedWorlds.
		world triggerEvent: #aboutToEnterWorld.
		Project spawnNewProcessAndTerminateOld: true
	] ifFalse: [
		SystemWindow clearTopWindow.	"break external ref to this project"
		newProcess _ [	
			ScheduledControllers resetActiveController.	"in case of walkback in #restore"
			showZoom ifFalse: [ScheduledControllers restore].
			ScheduledControllers searchForActiveController
		] fixTemps newProcess priority: Processor userSchedulingPriority.
		newProcess resume.		"lose the current process and its referenced morphs"
		Processor terminateActive.
	]! !

Project class removeSelector: #deleteCurrentAndEnterNew!
Project class removeSelector: #deleteCurrentAndOpenFromImagePath:!
Project class removeSelector: #specialTransition:!