The Trunk: System-dtl.163.mcz

David T. Lewis uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-dtl.163.mcz

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

Name: System-dtl.163
Author: dtl
Time: 9 November 2009, 9:55:32 am
UUID: 625c3b61-dd78-4cd5-a60f-dc90ee753144
Ancestors: System-dtl.162

Continue factoring Project into MVCProject and MorphicProject. Add method category 'enter' for methods associated with entering one project from another, including MVC-Morphic transition. Project>>enter: revert:saveForRevert: is significantly modified. Changes are in packages System, Morphic, and ST-80.

=============== Diff against System-dtl.162 ===============

Item was changed:
+ ----- Method: Project>>enter:revert:saveForRevert: (in category 'enter') -----
- ----- Method: Project>>enter:revert:saveForRevert: (in category 'menu messages') -----
  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 |
- | showZoom recorderOrNil old forceRevert response seg newProcess |
-
- (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 := (UIManager default chooseFrom: {
- 'Revert to saved version' translated.
- 'Cancel' translated.
- } title: '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) = 1.
- 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].
 
+ self isIncompletelyLoaded ifTrue:
+ [^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 := (UIManager default chooseFrom: {
+ 'Revert to saved version' translated.
+ 'Cancel' translated.
+ } title: '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) = 1.
+ 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.
+ CurrentProject 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].
+
+ CurrentProject pauseSoundPlayers.
+
+ 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.
+ recorderOrNil := old pauseEventRecorder.
  ProjectHistory remember: CurrentProject.
+ self setWorldForEnterFrom: old recorder: recorderOrNil.
-
- world isMorph
- ifTrue:
- [World := world.  "Signifies Morphic"
- 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"
+ self scheduleProcessForEnter: showZoom
+ !
- 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.
- ]!

Item was added:
+ ----- Method: Project>>isIncompletelyLoaded (in category 'enter') -----
+ isIncompletelyLoaded
+ "Answer true if project is incomplete and should be loaded from server "
+
+ ^ false!

Item was changed:
  ----- Method: Project>>armsLengthCommand:withDescription: (in category 'file in/out') -----
  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 subclassResponsibility!
- self isMorphic ifTrue: [
- world borderWidth: 0. "get rid of the silly default border"
- tempProject := MorphicProject new.
- foolingForm := world imageForm. "make them think they never left"
- tempCanvas := foolingForm getCanvas.
- bbox := foolingForm boundingBox.
- crossHatchColor := Color yellow alpha: 0.3.
- stride := 20.
- 10 to: bbox width by: stride do: [ :x |
- tempCanvas fillRectangle: (x@0 extent: 1@bbox height) fillStyle: crossHatchColor.
- ].
- 10 to: bbox height by: stride do: [ :y |
- tempCanvas fillRectangle: (0@y extent: bbox width@1) 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.
- ].
- !

Item was added:
+ ----- Method: Project>>pauseSoundPlayers (in category 'enter') -----
+ pauseSoundPlayers
+ "Pause sound players, subject to preference settings"
+
+ self subclassResponsibility!

Item was added:
+ ----- Method: Project>>scheduleProcessForEnter: (in category 'enter') -----
+ scheduleProcessForEnter: showZoom
+ "Complete the enter: by launching a new process"
+
+ self subclassResponsibility!

Item was changed:
  ----- Method: Project>>assureNavigatorPresenceMatchesPreference (in category 'menu messages') -----
  assureNavigatorPresenceMatchesPreference
  "Make sure that the current project conforms to the presence/absence of the navigator"
+ !
-
- | navigator navType wantIt |
- Smalltalk isMorphic ifFalse: [^ self].
- wantIt :=  Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator].
- navType := ProjectNavigationMorph preferredNavigator.
- navigator := world findA: navType.
- wantIt
- ifFalse:
- [navigator ifNotNil: [navigator delete]]
- ifTrue:
- [navigator isNil ifTrue:
- [(navigator := navType new)
- bottomLeft: world bottomLeft;
- openInWorld: world]]!

Item was added:
+ ----- Method: Project>>setWorldForEnterFrom:recorder: (in category 'enter') -----
+ setWorldForEnterFrom: old recorder: recorderOrNil
+ "Prepare world for enter."
+
+ self subclassResponsibility
+ !

Item was added:
+ ----- Method: Project>>setWorldForEmergencyRecovery (in category 'enter') -----
+ setWorldForEmergencyRecovery
+ "Prepare world for enter with an absolute minimum of mechanism.
+ An unrecoverable error has been detected in an isolated project."
+
+ self subclassResponsibility
+ !

Item was added:
+ ----- Method: Project>>pauseEventRecorder (in category 'enter') -----
+ pauseEventRecorder
+ "Suspend any event recorder, and return it if found"
+
+ ^ nil!

Item was added:
+ ----- Method: Project>>triggerClosingScripts (in category 'enter') -----
+ triggerClosingScripts
+ "If any scripts must be run on closing, run them now"
+ !

Item was changed:
+ ----- Method: Project>>finalExitActions (in category 'enter') -----
- ----- Method: Project>>finalExitActions (in category 'menu messages') -----
  finalExitActions
-
- | navigator |
-
- world isMorph ifTrue: [
- navigator := world findA: ProjectNavigationMorph.
- navigator ifNotNil: [navigator retractIfAppropriate].
- ].
  !

Item was changed:
+ ----- Method: Project>>enterForEmergencyRecovery (in category 'enter') -----
- ----- Method: Project>>enterForEmergencyRecovery (in category 'menu messages') -----
  enterForEmergencyRecovery
  "This version of enter invokes an absolute minimum of mechanism.
  An unrecoverable error has been detected in an isolated project.
  It is assumed that the old changeSet has already been revoked.
  No new process gets spawned here.  This will happen in the debugger."
 
  self isCurrentProject ifTrue: [^ self].
  CurrentProject saveState.
  CurrentProject := self.
  Display newDepthNoRestore: displayDepth.
  ChangeSet  newChanges: changeSet.
  TranscriptStream newTranscript: transcript.
  World pauseEventRecorder.
+ self setWorldForEmergencyRecovery.
+ UIProcess := Processor activeProcess
-
- world isMorph
- ifTrue:
- ["Entering a Morphic project"
- World := world.
- world install.
- world triggerOpeningScripts]
- ifFalse:
- ["Entering an MVC project"
- World := nil.
- Smalltalk at: #ScheduledControllers put: world.
- ScheduledControllers restore].
- UIProcess := Processor activeProcess.
  !

Item was changed:
+ ----- Method: Project>>viewLocFor: (in category 'displaying') -----
- ----- Method: Project>>viewLocFor: (in category 'menu messages') -----
  viewLocFor: exitedProject
  "Look for a view of the exitedProject, and return its center"
 
+ self subclassResponsibility!
- | ctlr |
- world isMorph
- ifTrue:
- [world submorphsDo:
- [:v |
- ((v isSystemWindow) and: [v model == exitedProject])
- ifTrue: [^v center]]]
- ifFalse:
- [ctlr := world controllerWhoseModelSatisfies: [:p | p == exitedProject].
- ctlr ifNotNil: [^ctlr view windowBox center]].
- ^Sensor cursorPoint "default result"!

Item was removed:
- ----- Method: Project>>navigatorFlapVisible (in category 'menu messages') -----
- navigatorFlapVisible
- "Answer whether a Navigator flap is visible"
-
- ^ (Flaps sharedFlapsAllowed and:
- [self flapsSuppressed not]) and:
- [self isFlapIDEnabled: 'Navigator' translated]!

Item was removed:
- ----- Method: Project>>finalEnterActions (in category 'menu messages') -----
- finalEnterActions
- "Perform the final actions necessary as the receiver project is entered"
-
- | navigator armsLengthCmd navType thingsToUnhibernate fixBlock |
-
- self projectParameters
- at: #projectsToBeDeleted
- ifPresent: [ :projectsToBeDeleted |
- self removeParameter: #projectsToBeDeleted.
- projectsToBeDeleted do: [ :each |
- Project deletingProject: each.
- each removeChangeSetIfPossible]].
-
- Locale switchAndInstallFontToID: self localeID.
-
- thingsToUnhibernate := world valueOfProperty: #thingsToUnhibernate ifAbsent: [#()].
- (thingsToUnhibernate anySatisfy:[:each|
- each isMorph and:[each hasProperty: #needsLayoutFixed]])
- ifTrue:[fixBlock := self displayFontProgress].
- thingsToUnhibernate do: [:each | each unhibernate].
- world removeProperty: #thingsToUnhibernate.
-
- fixBlock ifNotNil:[
- fixBlock value.
- world fullRepaintNeeded.
- ].
-
- 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)
- bottomLeft: world bottomLeft;
- openInWorld: world].
- navigator notNil & armsLengthCmd notNil ifTrue:
- [navigator color: Color lightBlue].
- armsLengthCmd notNil ifTrue:
- [Preferences showFlapsWhenPublishing
- ifFalse:
- [self flapsSuppressed: true.
- navigator ifNotNil: [navigator visible: false]].
- armsLengthCmd openInWorld: world].
- Smalltalk isMorphic ifTrue:
- [world reformulateUpdatingMenus.
- world presenter positionStandardPlayer.
- self assureMainDockingBarPresenceMatchesPreference].
-
- WorldState addDeferredUIMessage: [self startResourceLoading].!