The Trunk: System-mt.827.mcz

Marcel Taeumel uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-mt.827.mcz

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

Name: System-mt.827
Author: mt
Time: 9 May 2016, 1:41:03.140729 pm
UUID: e7d678e1-e245-0a49-b449-faca6c947a76
Ancestors: System-mt.826

REFACTORING THE PROJECTS MECHANISM
- Reduce and clean-up the footprint of new project kinds: saveState/loadState, finalEnterActions:/finalExitActions:, startResourceLoading/abortResourceLoading, aboutToLeaveWorld/aboutToEnterWorld (object events), scheduleProcessForEnter/terminateProcessForLeave
- Reduce full display restoring to #invalidate and #restore, which gives projects the chance to 1) clear their drawing caches and 2) redraw all their graphical objects.
- Clean-up project add/remove wrt. sub-projects and the whole project hierarchy. See #isTopProject, #beTopProject, #addProject:, #liftSubProjects, #removeProjectsFromSystem
- Provide a second way -- in addition to the Emergency Evaluator -- for recovering from recursive errors by trying a parent project of a different kind first. See #handlePrimitiveError:. This allows for more convenient recovery of such errors.
- For shrinking images, make MVCProject class >> #unloadMVC work again. This also applies to MorphicProject class >> #unloadMorphic in the near future.

=============== Diff against System-mt.826 ===============

Item was changed:
  ----- Method: Object>>primitiveError: (in category '*System-Recovery-error handling') -----
  primitiveError: aString
+ Project handlePrimitiveError: aString.!
- "This method is called when the error handling results in a recursion in
- calling on error: or halt or halt:."
- | hasTranscripter transcripter |
- hasTranscripter := (Smalltalk classNamed: #Transcripter)
- ifNotNil: [ :t | transcripter := t. true]
- ifNil: [false].
- (String
- streamContents:
- [:s |
- | context |
- s nextPutAll: '***System error handling failed***'.
- s cr; nextPutAll: aString.
- context := thisContext sender sender.
- 20 timesRepeat: [context == nil ifFalse: [s cr; print: (context := context sender)]].
- s cr; nextPutAll: '-------------------------------'.
- hasTranscripter
- ifTrue: [
- s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
- s cr; nextPutAll: 'Type any other character to restart.']
- ifFalse: [
- s cr; nextPutAll: 'Type any character to restart.']])
- displayAt: 0 @ 0.
- [Sensor keyboardPressed] whileFalse.
- Sensor keyboard = Character cr ifTrue: [
- hasTranscripter ifTrue: [transcripter emergencyEvaluator]].
- Project current resetDisplay!

Item was changed:
  Model subclass: #Project
+ instanceVariableNames: 'world uiManager changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject projectParameters version urlList environment lastDirectory lastSavedAtSeconds projectPreferenceFlagDictionary resourceManager'
- instanceVariableNames: 'world uiManager changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject guards projectParameters version urlList environment lastDirectory lastSavedAtSeconds projectPreferenceFlagDictionary resourceManager'
  classVariableNames: 'AllProjects CurrentProject GoalFreePercent GoalNotMoreThan'
  poolDictionaries: ''
  category: 'System-Support'!
 
  !Project commentStamp: 'cbr 7/27/2010 21:36' prior: 0!
  A Project stores the state of a complete Squeak desktop, including
  the windows, and the currently active changeSet.  A project knows who
  its parent project is.  When you change projects, whether by entering
  or exiting, the screen state of the project being exited is saved in
  that project.
 
  A project is retained by its view in the parent world.  It is
  effectively named by the name of its changeSet, which can be changed
  either by renaming in a changeSorter, or by editing the label of its
  view from the parent project.
 
  As the site of major context switch, Projects are the locus of
  swapping between the old MVC and the new Morphic worlds.  The
  distinction is based on whether the variable 'world' contains a
  WorldMorph or a ControlManager.
 
  Saving and Loading
  Projects may be stored on the disk in external format.  (Project
  named: 'xxx') exportSegment, or choose 'store project on file...'.
  Projects may be loaded from a server and stored back.  Storing on a
  server never overwrites;  it always makes a new version.  A project
  remembers the url of where it lives in urlList.  The list is length
  one, for now.  The url may point to a local disk instead of a server.
  All projects that the user looks at are cached in the Squeaklet
  folder.  Sorted by server.  The cache holds the most recent version
  only.
 
  When a project is loaded into Squeak, its objects are converted to
  the current version.  There are three levels of conversion.  First,
  each object is converted from raw bits to an object in its old
  format.  Then it is sent some or all of these messages:
  comeFullyUpOnReload: smartRefStream   Used to
  re-discover an object that already exists in this image, such as a
  resource, global variable, Character, or Symbol.  (sent to objects in
  outPointers)
  convertToCurrentVersion: varDict refStream: smartRefStrm
  fill in fields that have been added to a class since
  the object was stored.  Used to set the extra inst var to a default
  value.  Or, return a new object of a different class.  (sent to
  objects that changed instance variables)
  fixUponLoad: aProject refStream: smartRefStrm
  change the object due to conventions that have changed on the
  project level.  (sent to all objects in the incoming project)
 
  Here is the calling sequence for storing out a Project:
  Project saveAs
  Project storeOnServer
  Project storeOnServerWithProgressInfo
  Project storeOnServerInnards
  Project exportSegmentFileName:directory:
  Project exportSegmentWithChangeSet:fileName:directory:
  ImageSegment writeForExportWithSources:inDirectory:changeSet:
 
  !

Item was changed:
  ----- Method: Project class>>deletingProject: (in category 'utilities') -----
  deletingProject: outgoingProject
+ "Delete the outgoing project and all its sub-projects. Start with the sub-projects."
+
+ "Delete all sub-projects."
+ outgoingProject subProjects do: [:p | self deletingProject: p].
 
+ "Forget that it ever existed. We have to do that now to avoid other code iterating over the partially removed project."
+ self forget: outgoingProject.
+
+ "Give all registered projects the chance to release their references."
+ self allProjects do: [:p | p deletingProject: outgoingProject].
+
+ "Really clean-up everything related to the outgoing project."
+ self releaseProjectReferences: outgoingProject.!
- | pvmClass pvControllerClass |
- pvmClass := Smalltalk at: #ProjectViewMorph ifAbsent: [nil].
- pvControllerClass := Smalltalk at: #ProjectController ifAbsent: [nil].
- ImageSegment allSubInstancesDo: [:seg |
- seg ifOutPointer: outgoingProject thenAllObjectsDo: [:obj |
- (obj isKindOf: pvmClass) ifTrue: [obj deletingProject: outgoingProject.  obj abandon].
- (obj isKindOf: Project) ifTrue: [obj deletingProject: outgoingProject]]].
- self allProjects do: [:p | p deletingProject: outgoingProject]. "ones that are in"
- pvmClass ifNotNil: [
- pvmClass allSubInstancesDo: [:p |
- p deletingProject: outgoingProject.
- p project == outgoingProject ifTrue: [p abandon]]].
- pvControllerClass ifNotNil: [
- pvControllerClass allInstancesDo: [ :pvc |
- ((pvc model parent isNil or: [pvc model parent == Project current]) and: [pvc model == outgoingProject])
- ifTrue: [ pvc closeAndUnscheduleNoTerminate ]]].
- AllProjects := self allProjects copyWithout: outgoingProject.!

Item was added:
+ ----- Method: Project class>>flattenProjectHierarchy (in category 'utilities') -----
+ flattenProjectHierarchy
+ "Clean-up project hierarchy. Make all projects be sub-projects of the top project."
+
+ self allSubInstancesDo: [:ea | ea setParent: self topProject].!

Item was changed:
  ----- Method: Project class>>forget: (in category 'utilities') -----
  forget: aProject
 
+ AllProjects := self allProjects copyWithout: aProject.!
- AllProjects := self allProjects reject: [ :x | x == aProject].
- !

Item was added:
+ ----- Method: Project class>>handlePrimitiveError: (in category 'error recovery') -----
+ handlePrimitiveError: errorMessage
+ "This method is called when the error handling results in a recursion in
+ calling on error: or halt or halt:.."
+
+ self tryOtherProjectForRecovery: errorMessage.
+ self tryEmergencyEvaluatorForRecovery: errorMessage.
+
+ Project current restoreDisplay.!

Item was added:
+ ----- Method: Project class>>initialize (in category 'class initialization') -----
+ initialize
+
+ Smalltalk addToStartUpList: self.
+ Smalltalk addToShutDownList: self.!

Item was added:
+ ----- Method: Project class>>releaseProjectReferences: (in category 'utilities') -----
+ releaseProjectReferences: outgoingProject
+ "Give all kinds of projects the chance to do generic clean-up to their best knowledge. Consider image segments first."
+
+ Smalltalk garbageCollect.
+
+ ImageSegment allSubInstancesDo: [:seg |
+ seg ifOutPointer: outgoingProject thenAllObjectsDo: [:obj |
+ (obj isKindOf: Project) ifTrue: [obj deletingProject: outgoingProject]]].
+
+ self allSubclassesDo: [:projectClass |
+ (projectClass selectors includes: #releaseProjectReferences:)
+ ifTrue: [projectClass releaseProjectReferences: outgoingProject]].!

Item was added:
+ ----- Method: Project class>>removeProjectsFromSystem (in category 'shrinking') -----
+ removeProjectsFromSystem
+ "Remove all projects of this kind from the system, reorganizing the project hierarchy as needed.
+ This method was originally implemented as SmalltalkImage>>zapMVCProjects in earlier
+ versions of Squeak."
+
+ "MVCProject removeProjectsFromSystem"
+ "MorphicProject removeProjectsFromSystem"
+
+ | projectsToRemove projectsToReorganize |
+
+ (Project current isKindOf: self) ifTrue: [
+ "We have to enter another project to unload this project kind."
+ (Project subclasses detect: [:ea | (ea includesBehavior: self) not] ifNone: [])
+ ifNil: [^ Error signal: 'You have to enter another kind of project.']
+ ifNotNil: [:projectClass |
+ ^ projectClass new
+ addDeferredUIMessage: [self removeProjectsFromSystem];
+ enter]].
+
+ (Project topProject isKindOf: self) ifTrue: [
+ "We have to become the top project now."
+ Project current beTopProject].
+
+ Smalltalk garbageCollect. "So allInstances is precise"
+ projectsToRemove := OrderedCollection new.
+ projectsToReorganize := OrderedCollection new.
+
+ Project allSubInstancesDo: [:proj |
+ (proj isKindOf: self)
+ ifTrue: [projectsToRemove add: proj]
+ ifFalse: [(proj parent isKindOf: self)
+ ifTrue: [projectsToReorganize add: proj]]].
+
+ projectsToReorganize do: [:proj |
+ "Remove views and refs."
+ proj parent deletingProject: proj.
+ "Add as sub-project to top project to avoid cycles and confusion. Ignore the current project."
+ Project topProject addProject: proj].
+
+ projectsToRemove do: [:proj | proj delete].!

Item was added:
+ ----- Method: Project class>>returnToParentProject (in category 'utilities') -----
+ returnToParentProject
+
+ Project current isTopProject
+ ifFalse: [Project current parent enter].!

Item was added:
+ ----- Method: Project class>>shutDown: (in category 'snapshots') -----
+ shutDown: quitting
+
+ quitting ifTrue: [
+ Project current world triggerEvent: #aboutToLeaveWorld].!

Item was removed:
- ----- Method: Project class>>spawnNewProcess (in category 'deprecated') -----
- spawnNewProcess
- "Meaningful only for a Morphic project, but retained here to protect for possible
- references from e.g. image segments"
-
- self current spawnNewProcess!

Item was removed:
- ----- Method: Project class>>spawnNewProcessAndTerminateOld: (in category 'deprecated') -----
- spawnNewProcessAndTerminateOld: terminate
- "Meaningful only for a Morphic project, but retained here to protect for possible
- references from e.g. image segments"
-
- ^ self current spawnNewProcessAndTerminateOld: terminate
- !

Item was removed:
- ----- Method: Project class>>spawnNewProcessIfThisIsUI: (in category 'deprecated') -----
- spawnNewProcessIfThisIsUI: suspendedProcess
- "Meaningful only for a Morphic project, but retained here to protect for possible
- references from e.g. image segments"
-
- self current spawnNewProcessIfThisIsUI: suspendedProcess
-
- !

Item was added:
+ ----- Method: Project class>>startUp: (in category 'snapshots') -----
+ startUp: startAfresh
+
+ Project current restoreDisplay.
+
+ startAfresh ifTrue: [
+ Project current world triggerEvent: #aboutToEnterWorld].!

Item was added:
+ ----- Method: Project class>>tryEmergencyEvaluatorForRecovery: (in category 'error recovery') -----
+ tryEmergencyEvaluatorForRecovery: errorMessage
+
+ | hasTranscripter transcripter |
+ hasTranscripter := (Smalltalk classNamed: #Transcripter)
+ ifNotNil: [ :t | transcripter := t. true]
+ ifNil: [false].
+ (String
+ streamContents:
+ [:s |
+ | context |
+ s nextPutAll: '***System error handling failed***'.
+ s cr; nextPutAll: errorMessage.
+ context := thisContext sender sender.
+ 20 timesRepeat: [context == nil ifFalse: [s cr; print: (context := context sender)]].
+ s cr; nextPutAll: '-------------------------------'.
+ hasTranscripter
+ ifTrue: [
+ s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
+ s cr; nextPutAll: 'Type any other character to restart.']
+ ifFalse: [
+ s cr; nextPutAll: 'Type any character to restart.']])
+ displayAt: 0 @ 0.
+
+ [Sensor keyboardPressed] whileFalse.
+
+ Sensor keyboard = Character cr ifTrue: [
+ hasTranscripter ifTrue: [transcripter emergencyEvaluator]].!

Item was added:
+ ----- Method: Project class>>tryOtherProjectForRecovery: (in category 'error recovery') -----
+ tryOtherProjectForRecovery: errorMessage
+ "Try entering the parent project if it uses a different user interface. We determine this by comparing the project's class."
+
+ | safeProject nextProject |
+ nextProject := Project current.
+ safeProject := nil.
+ [safeProject notNil or: [nextProject isTopProject]] whileFalse: [
+ nextProject := nextProject parent.
+ nextProject class == Project current class
+ ifFalse: [safeProject := nextProject]].
+ safeProject ifNotNil: [:p |
+ p enterForEmergencyRecovery.
+ "Active process will usually suspend after this."].!

Item was changed:
+ ----- Method: Project class>>uiProcess (in category 'constants') -----
- ----- Method: Project class>>uiProcess (in category 'instance creation') -----
  uiProcess
 
  ^ self current uiProcess!

Item was removed:
- ----- Method: Project>>addGuard: (in category 'accessing') -----
- addGuard: anObject
- "Add the given object to the list of objects receiving #okayToEnterProject on Project entry"
- guards ifNil:[guards := WeakArray with: anObject]
- ifNotNil:[guards := guards copyWith: anObject].!

Item was added:
+ ----- Method: Project>>addProject: (in category 'sub-projects & hierarchy') -----
+ addProject: aProject
+ "Add the given project as sub-project."
+
+ aProject setParent: self.!

Item was changed:
+ ----- Method: Project>>addSubProjectNamesTo:indentation: (in category 'printing') -----
- ----- Method: Project>>addSubProjectNamesTo:indentation: (in category 'accessing') -----
  addSubProjectNamesTo: aStream indentation: anIndentation
  "Add the names of the receiver and all its subprojects, and all *their* subprojects recursively, to aStream, indenting by the specified number of tab stops "
 
  self isTopProject ifFalse:  "circumvent an annoying cr at the top "
  [aStream cr].  
  aStream tab: anIndentation; nextPutAll: self name.
  self subProjects do:
  [:p |
  p addSubProjectNamesTo: aStream indentation: anIndentation + 1]!

Item was added:
+ ----- Method: Project>>beTopProject (in category 'sub-projects & hierarchy') -----
+ beTopProject
+
+ self isTopProject ifTrue: [^ self].
+
+ self parent deletingProject: self. "Just remove views and refs to me."
+ self addProject: self class topProject.
+ self setParent: self.!

Item was changed:
+ ----- Method: Project>>children (in category 'sub-projects & hierarchy') -----
- ----- Method: Project>>children (in category 'accessing') -----
  children
  "Answer a list of all the subprojects of the receiver"
 
  | children |
  children := OrderedCollection new.
  Project allProjects do: [ :p |
  (self == p parent and: [self ~~ p]) ifTrue:
  [ children add: p ]].
  ^ children
 
  "
  Project topProject children
  "!

Item was removed:
- ----- Method: Project>>defaultBackgroundColor (in category 'initialization') -----
- defaultBackgroundColor
- ^ self subclassResponsibility!

Item was added:
+ ----- Method: Project>>delete (in category 'release') -----
+ delete
+
+ self isCurrentProject
+ ifTrue: [^ Error signal: 'Cannot delete the current project.'].
+
+ self removeChangeSetIfPossible.
+
+ ProjectHistory forget: self.
+ Project deletingProject: self.!

Item was changed:
  ----- Method: Project>>deletingProject: (in category 'release') -----
+ deletingProject: outgoingProject
- deletingProject: aProject
  "Clear my previousProject link if it points at the given Project, which is being deleted."
 
+ parentProject == outgoingProject
+ ifTrue: [parentProject := parentProject parent].
+
+ previousProject == outgoingProject
+ ifTrue: [previousProject := previousProject previousProject].
+ previousProject == outgoingProject
- self flag: #bob. "zapping projects"
-
- parentProject == aProject ifTrue: [
- parentProject := parentProject parent
- ].
- previousProject == aProject
  ifTrue: [previousProject := nil].
+
+ nextProject == outgoingProject
+ ifTrue: [nextProject := nextProject nextProject].
+ nextProject == outgoingProject
+ ifTrue: [nextProject := nil].!
- nextProject == aProject
- ifTrue: [nextProject := nil]
- !

Item was added:
+ ----- Method: Project>>displayDepthChanged (in category 'displaying') -----
+ displayDepthChanged
+ "The depth of the display has changed."
+ !

Item was changed:
  ----- Method: Project>>displaySizeChanged (in category 'displaying') -----
  displaySizeChanged
+ "Inform the current project that its display size has changed. Usually, projects invalidate all their drawing caches and restore their graphical contents."
+
+ self invalidate; restore.!
- "Inform the current project that its display size has changed"
- !

Item was changed:
+ ----- Method: Project>>enter (in category 'enter') -----
- ----- Method: Project>>enter (in category 'menu messages') -----
  enter
  "Enter the new project"
  self enter: (CurrentProject parent == self) revert: false saveForRevert: false.!

Item was changed:
+ ----- Method: Project>>enter: (in category 'enter') -----
- ----- Method: Project>>enter: (in category 'menu messages') -----
  enter: returningFlag
  self enter: returningFlag revert: false saveForRevert: false!

Item was changed:
  ----- Method: Project>>enter:revert:saveForRevert: (in category 'enter') -----
  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."
 
+ | leavingProject forceRevert response seg |
- | showZoom recorderOrNil old forceRevert response seg |
 
+ self isIncompletelyLoaded
+ ifTrue: [^ self loadFromServer: true].
+ self isCurrentProject
+ ifTrue: [^ self].
+
- 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 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]].
 
+ "Update display depth for leaving and entring project."
- 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: [
+ CurrentProject removeChangeSetIfPossible. "keep this stuff from accumulating"
- old removeChangeSetIfPossible. "keep this stuff from accumulating"
  nextProject := nil
  ] ifFalse: [
  returningFlag
  ifTrue: [nextProject := CurrentProject]
  ifFalse: [previousProject := CurrentProject].
  ].
 
+ CurrentProject world triggerEvent: #aboutToLeaveWorld.
+ CurrentProject abortResourceLoading.
+ CurrentProject finalExitActions: self.
- recorderOrNil := old pauseEventRecorder.
-
  CurrentProject saveState.
- CurrentProject finalExitActions.
 
+ "********** SWITCHING CURRENT PROJECT **********"
+ leavingProject := CurrentProject.
- "Now I am the current project."
  CurrentProject := self.
+ ProjectHistory remember: self.
+ "********** SWITCHING CURRENT PROJECT **********"
- self installProjectPreferences.
- ChangeSet  newChanges: changeSet.
- TranscriptStream newTranscript: transcript.
- Sensor flushKeyboard.
- ProjectHistory remember: CurrentProject.
- self setWorldForEnterFrom: old recorder: recorderOrNil.
 
+ self loadState.
+ self finalEnterActions: leavingProject.
+ self addDeferredUIMessage: [self startResourceLoading].
+ self world triggerEvent: #aboutToEnterWorld.
+
+ "Save project for revert."
  saveForRevert ifTrue: [
  Smalltalk garbageCollect. "let go of pointers"
+ leavingProject storeSegment.
+ "result :=" leavingProject world isInMemory
- old storeSegment.
- "result :=" old world isInMemory
  ifTrue: ['Can''t seem to write the project.']
+ ifFalse: [leavingProject projectParameters at: #revertToMe put:
+ leavingProject world xxxSegment clone].
- 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.
+
+ "Now that everything is set up, we can show zoom animation."
+ self showZoom
+ ifTrue: [self displayZoom: leavingProject parent ~~ self "Entering?"]
+ ifFalse: [self restore].
+
+ "Update processes at last."
+ self scheduleProcessForEnter.
+ leavingProject terminateProcessForLeave.
-
- "Complete the enter: by launching a new process"
- self finalEnterActions.
- self scheduleProcessForEnter: showZoom.
- old terminateProcessForLeave.
  !

Item was added:
+ ----- Method: Project>>enterForEmergencyRecovery (in category 'enter - recovery') -----
+ enterForEmergencyRecovery
+ "Stripped down verion of #enter:revert:saveForRevert:. More error handling. Less features."
+
+ | leavingProject process |
+ self isCurrentProject ifTrue: [^ self].
+
+ ProjectHistory remember: CurrentProject.
+ nextProject := CurrentProject.
+
+ [ CurrentProject world triggerEvent: #aboutToLeaveWorld.
+ CurrentProject abortResourceLoading.
+ CurrentProject finalExitActions: self.
+ CurrentProject saveState ] on: Error do: [:ex | "Ignore." ].
+
+ "********** SWITCHING CURRENT PROJECT **********"
+ leavingProject := CurrentProject.
+ CurrentProject := self.
+ ProjectHistory remember: self.
+ "********** SWITCHING CURRENT PROJECT **********"
+
+ self loadState.
+ self finalEnterActions: leavingProject.
+ self addDeferredUIMessage: [self startResourceLoading].
+ self world triggerEvent: #aboutToEnterWorld.
+
+ "Now that everything is set up, we can show zoom animation.
+ Do we really need this in case of an emergency?"
+ self showZoom
+ ifTrue: [self displayZoom: leavingProject parent ~~ self "Entering?"]
+ ifFalse: [self restore].
+
+ "Update processes at last."
+ self scheduleProcessForEnter.
+
+ "Do not terminate but suspend the projects ui process to support debugging."
+ process := leavingProject uiProcess.
+ self addDeferredUIMessage: [process debugWithTitle: 'FATAL PROJECT ERROR!!'].
+ leavingProject suspendProcessForDebug.!

Item was removed:
- ----- Method: Project>>finalEnterActions (in category 'enter') -----
- finalEnterActions
- !

Item was added:
+ ----- Method: Project>>finalEnterActions: (in category 'enter') -----
+ finalEnterActions: leavingProject
+
+ !

Item was removed:
- ----- Method: Project>>finalExitActions (in category 'enter') -----
- finalExitActions
- !

Item was added:
+ ----- Method: Project>>finalExitActions: (in category 'enter') -----
+ finalExitActions: enteringProject
+
+ SoundService stop.!

Item was added:
+ ----- Method: Project>>forget (in category 'release') -----
+ forget
+
+ self isCurrentProject
+ ifTrue: [^ Error signal: 'Cannot forget the current project.'].
+
+ self class forget: self.!

Item was changed:
+ ----- Method: Project>>handleFatalDrawingError: (in category 'displaying') -----
- ----- Method: Project>>handleFatalDrawingError: (in category 'utilities') -----
  handleFatalDrawingError: errMsg
  "Handle a fatal drawing error."
 
+ Display deferUpdates: false. "Just in case"
+ self primitiveError: errMsg.
+
+ "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"!
- self error: errMsg "overridden in MorphicProject"
- !

Item was changed:
  ----- Method: Project>>imageFormOfSize:depth: (in category 'displaying') -----
  imageFormOfSize: extentPoint depth: d
  | newDisplay |
  newDisplay := DisplayScreen extent: extentPoint depth: d.
+ Display replacedBy: newDisplay do:[self invalidate; restore].
- Display replacedBy: newDisplay do:[self restore].
  ^newDisplay!

Item was changed:
+ ----- Method: Project>>interruptName: (in category 'debugging') -----
- ----- Method: Project>>interruptName: (in category 'scheduling') -----
  interruptName: labelString
  "Create a Notifier on the active scheduling process with the given label."
 
  ^ self subclassResponsibility
  !

Item was changed:
+ ----- Method: Project>>interruptName:preemptedProcess: (in category 'debugging') -----
- ----- Method: Project>>interruptName:preemptedProcess: (in category 'scheduling') -----
  interruptName: labelString preemptedProcess: theInterruptedProcess
  "Create a Notifier on the active scheduling process with the given label."
 
  ^ self subclassResponsibility
  !

Item was changed:
+ ----- Method: Project>>isCurrentProject (in category 'testing') -----
- ----- Method: Project>>isCurrentProject (in category 'accessing') -----
  isCurrentProject
 
  ^self == CurrentProject!

Item was changed:
+ ----- Method: Project>>isIncompletelyLoaded (in category 'testing') -----
- ----- 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>>isTopProject (in category 'sub-projects & hierarchy') -----
- ----- Method: Project>>isTopProject (in category 'accessing') -----
  isTopProject
  "Return true only if this is the top project (its own parent).
  Also include the test here for malformed project hierarchy."
 
  parentProject == self ifTrue: [^ true].
  parentProject == nil ifTrue: [self error: 'No project should have a nil parent'].
  ^ false!

Item was added:
+ ----- Method: Project>>liftSubProjects (in category 'sub-projects & hierarchy') -----
+ liftSubProjects
+ "Lift my sub-projects to my parent project."
+
+ self parent ifNil: [^ Error signal: 'Cannot lift sub-project because I have to parent.'].
+
+ self subProjects do: [:ea | self parent addProject: ea].!

Item was added:
+ ----- Method: Project>>loadState (in category 'enter') -----
+ loadState
+
+ self installProjectPreferences.
+ ChangeSet  newChanges: changeSet.
+ thumbnail ifNotNil: [:form | form unhibernate].
+ TranscriptStream newTranscript: transcript.
+ !

Item was changed:
  ----- Method: Project>>okToChange (in category 'release') -----
  okToChange
  "Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation"
 
+ | answer |
+ (self confirm: ('Do you really want to delete the project\{1}\and all its content?' withCRs translated format:{self name}))
+ ifFalse: [^ false].
- | ok is list |
- self subProjects size  >0 ifTrue:
- [self inform:
- ('The project {1}
- contains sub-projects.  You must remove these
- explicitly before removing their parent.' translated format:{self name}).
- ^ false].
- ok := world isNil or: [world isMorph not and: [world scheduledControllers size <= 1]].
- ok ifFalse: [self isMorphic ifTrue:
- [self parent == CurrentProject
- ifFalse: [^ true]]].  "view from elsewhere.  just delete it."
- ok := self confirm:
- ('Really delete the project
- {1}
- and all its windows?' translated format:{self name}).
-
- ok ifFalse: [^ false].
 
+ self subProjects ifNotEmpty: [:sp |
+ answer := Project current uiManager
+ chooseFrom: #(
+ "1" 'Lift all sub-projects'
+ "2" 'Discard all sub-projects (NO UNDO!!)'
+ "3 or 0" 'Cancel')
+ lines: #(2)
+ title: ('The project {1}\contains {2} sub-project(s).' withCRs translated format:{self name. sp size}).
+
+ (answer = 0 or: [answer = 3]) ifTrue: [^ false].
+ answer = 1 ifTrue: [self liftSubProjects. ^ true].
+ answer = 2 ifTrue: [^ sp allSatisfy: [:ea | ea okToChange]]].
+
+ ^ true!
- world isMorph ifTrue:
- [Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass |
- world submorphs do:   "special release for wonderlands"
- [:m | (m isKindOf: aClass)
- and: [m getWonderland release]]].
- "Remove Player classes and metaclasses owned by project"
- is := ImageSegment new arrayOfRoots: (Array with: self).
- (list := is rootsIncludingPlayers) ifNotNil:
- [list do: [:playerCls |
- (playerCls respondsTo: #isMeta) ifTrue:
- [playerCls isMeta ifFalse:
- [playerCls removeFromSystemUnlogged]]]]].
-
- self removeChangeSetIfPossible.
- "do this last since it will render project inaccessible to #allProjects and their ilk"
- ProjectHistory forget: self.
- Project deletingProject: self.
- ^ true
- !

Item was changed:
+ ----- Method: Project>>parent (in category 'sub-projects & hierarchy') -----
- ----- Method: Project>>parent (in category 'accessing') -----
  parent
  ^ parentProject!

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

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

Item was changed:
  ----- Method: Project>>release (in category 'release') -----
  release
 
+ self delete.
+
+ world == nil ifFalse: [
+ world release.
- self flag: #bob. "this can be trouble if Projects are reused before garbage collection"
- world == nil ifFalse:
- [world release.
  world := nil].
+
  ^ super release!

Item was changed:
  ----- Method: Project>>removeAllOtherProjects (in category 'shrinking') -----
  removeAllOtherProjects
  "Remove all other projects from the system, and set the current project as the root
  project. This method was originally implemented as SmalltalkImage>>zapAllOtherProjects
  in earlier versions of Squeak."
 
  "Project current removeAllOtherProjects"
+
+ Project current == self ifFalse: [
+ ^ self
+ addDeferredUIMessage: [self removeAllOtherProjects];
+ enter].
 
+ self beTopProject.
+
+ Project rebuildAllProjects.  "Does a GC"
+ Project allProjects do: [:p | p == Project current ifFalse: [p delete]].
+
- Project allSubInstancesDo: [:p | p setParent: nil].
- Project current setParent: Project current.
- ScheduledControllers == Project current world ifFalse: [ScheduledControllers := nil].
  TheWorldMenu allInstancesDo: [:m | 1 to: m class instSize do: [:i | m instVarAt: i put: nil]].
  ChangeSet classPool at: #AllChangeSets put: nil.
- Project classPool at: #AllProjects put: nil.
  ProjectHistory currentHistory initialize.
  CommandHistory resetAllHistory.
  ChangeSet initialize.
+
+ self assert: Project current == self.!
- Project rebuildAllProjects.  "Does a GC"
- Project allSubInstancesDo: [:p |
- p == Project current ifFalse: [Project deletingProject: p]].
- ^Project current.
- !

Item was removed:
- ----- Method: Project>>resetDisplay (in category 'displaying') -----
- resetDisplay
- "Bring the display to a usable state after handling primitiveError."
-
- self subclassResponsibility!

Item was changed:
  ----- Method: Project>>restore (in category 'displaying') -----
  restore
+ "Redraw the entire project."
+
+ self subclassResponsibility.!
- "Redraw the entire Project"
- ^self subclassResponsibility!

Item was changed:
  ----- Method: Project>>restoreDisplay (in category 'displaying') -----
  restoreDisplay
+ "Force re-initialization of the display. Uses display-changed notification to re-draw everything."
- "Clear the screen to gray and then redisplay all the scheduled views."
 
+ Display restore.!
- self subclassResponsibility!

Item was changed:
  ----- Method: Project>>saveState (in category 'enter') -----
  saveState
  "Save the current state in me prior to leaving this project"
 
+ self saveProjectPreferences.
  changeSet := ChangeSet current.
+ thumbnail ifNotNil: [:form | form hibernate].
- thumbnail ifNotNil: [thumbnail hibernate].
  transcript := Transcript.!

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

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

Item was changed:
+ ----- Method: Project>>setParent: (in category 'sub-projects & hierarchy') -----
- ----- Method: Project>>setParent: (in category 'accessing') -----
  setParent: newParent
 
  parentProject := newParent.
  nextProject := previousProject := nil.!

Item was removed:
- ----- 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 removed:
- ----- Method: Project>>setWorldForEnterFrom:recorder: (in category 'enter') -----
- setWorldForEnterFrom: old recorder: recorderOrNil
- "Prepare world for enter."
-
- self subclassResponsibility
- !

Item was changed:
+ ----- Method: Project>>subProjects (in category 'sub-projects & hierarchy') -----
- ----- Method: Project>>subProjects (in category 'release') -----
  subProjects
+ "Answer a list of all the subprojects of the receiver. By default, use the list of all projects and traverse the parent."
- "Answer a list of all the subprojects of the receiver. By default, there are no sub-projects."
 
+ ^ Project allProjects select: [:p | p parent == self and: [p isTopProject not]]!
- ^ #()!

Item was added:
+ ----- Method: Project>>suspendProcessForDebug (in category 'enter - recovery') -----
+ suspendProcessForDebug
+ "If this project fails, let another project debug this project's main loop/process. Default behavior is terminating the process. Hence, no debugging."
+
+ self terminateProcessForLeave.!

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

Item was added:
+ ----- Method: Project>>windowIsClosing (in category 'release') -----
+ windowIsClosing
+
+ self prepareForDelete.!

Item was changed:
+ ----- Method: Project>>withChildrenDo: (in category 'sub-projects & hierarchy') -----
- ----- Method: Project>>withChildrenDo: (in category 'accessing') -----
  withChildrenDo: aBlock
  "Evaluate the block first with the receiver as argument, then, recursively and depth first, with each of the receiver's children as argument"
 
  aBlock value: self.
  self children do: [:p |
  p withChildrenDo: aBlock ]!

Item was changed:
  ----- Method: WrappedBreakpoint>>run:with:in: (in category 'evaluation') -----
  run: aSelector with: anArray in: aReceiver
  | process |
  process := Process
  forContext: (MethodContext
  sender: thisContext sender
  receiver: aReceiver
  method: method
  arguments: anArray)
  priority: Processor activeProcess priority.
  ToolSet
  debug: process context: process suspendedContext
  label:  'Breakpoint in ' , method methodClass name , '>>#' , method selector
  contents: nil fullView: true.
+ Project current spawnNewProcessIfThisIsUI: Processor activeProcess.
- Project spawnNewProcessIfThisIsUI: Processor activeProcess.
  thisContext swapSender: nil.
  Processor activeProcess terminate.!