[squeak-dev] The Trunk: Morphic-tpr.1968.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Apr 19 18:48:45 UTC 2022
tim Rowledge uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tpr.1968.mcz
==================== Summary ====================
Name: Morphic-tpr.1968
Author: tpr
Time: 19 April 2022, 11:48:37.562456 am
UUID: cc640262-3b82-4ae0-a043-458a8ddf28e6
Ancestors: Morphic-mt.1967
Use the new ToolBuilder ability to show a list of options - typically a small number, maybe with a cancel button etc - as opposed to an arbitrary list of values. This separates it out from the chooseFrom:... protocol.
Also update "UIManager default" with "Project uiManager"
=============== Diff against Morphic-mt.1967 ===============
Item was changed:
----- Method: HaloMorph>>maybeDismiss:with: (in category 'private') -----
maybeDismiss: evt with: dismissHandle
"Ask hand to dismiss my target if mouse comes up in it."
evt hand obtainHalo: self.
(dismissHandle containsPoint: evt cursorPoint)
+ ifFalse:
+ [self delete.
- ifFalse: [
- self delete.
target addHalo: evt]
+ ifTrue:
+ [target resistsRemoval ifTrue:
+ [(Project uiManager
+ chooseOptionFrom:
+ {'Yes' translated.
+ 'Um, no, let me reconsider' translated.}
+ title: 'Really throw this away?' translated) = 1 ifFalse: [^ self]].
- ifTrue: [
- target resistsRemoval ifTrue:
- [(UIManager default chooseFrom: {
- 'Yes' translated.
- 'Um, no, let me reconsider' translated.
- } title: 'Really throw this away?' translated) = 1 ifFalse: [^ self]].
evt hand removeHalo.
self delete.
target dismissViaHalo.
self currentWorld presenter flushPlayerListCache].!
Item was changed:
----- Method: MorphicProject>>exportSegmentWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') -----
exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName
directory: aDirectory withoutInteraction: noInteraction
"Store my project out on the disk as an *exported*
ImageSegment. All outPointers will be in a form that can be resolved
in the target image. Name it <project name>.extSeg. Whatdo we do
about subProjects, especially if they are out as local image
segments? Force them to come in?
Player classes are included automatically."
| is str ans revertSeg roots holder collector fd mgr stacks |
"Files out a changeSet first, so that a project can contain
its own classes"
world ifNil: [^ false].
world presenter ifNil: [^ false].
ScrapBook default emptyScrapBook.
(world respondsTo: #cleanUpReferences) ifTrue:
[world cleanUpReferences].
world currentHand pasteBuffer: nil. "don't write the paste buffer."
world currentHand mouseOverHandler initialize. "forget about any
references here"
+ "Display checkCurrentHandForObjectToPaste."
- "Display checkCurrentHandForObjectToPaste."
Command initialize.
world clearCommandHistory.
world fullReleaseCachedState; releaseViewers.
world cleanseStepList.
+ world localFlapTabs size = world flapTabs size ifFalse:
+ [noInteraction ifTrue: [^ false].
- world localFlapTabs size = world flapTabs size ifFalse: [
- noInteraction ifTrue: [^ false].
self error: 'Still holding onto Global flaps'].
world releaseSqueakPages.
+ Smalltalk
+ at: #ScriptEditorMorph
+ ifPresent:
+ [:s |
+ s writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false])].
- Smalltalk at: #ScriptEditorMorph ifPresent: [:s |
- s writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false])].
holder := Project allProjects. "force them in to outPointers, where
DiskProxys are made"
"Just export me, not my previous version"
revertSeg := self parameterAt: #revertToMe.
self removeParameter: #revertToMe.
roots := OrderedCollection new.
+ roots
+ add: self;
+ add: world;
+ add: transcript;
+ add: aChangeSetOrNil;
+ add: thumbnail;
+ add: world activeHand.
- roots add: self; add: world; add: transcript; add: aChangeSetOrNil; add: thumbnail; add: world activeHand.
+ roots := roots reject: [ :x | x isNil]. "early saves may not have active hand or thumbnail"
- "; addAll: classList; addAll: (classList collect: [:cls | cls class])"
- roots := roots reject: [ :x | x isNil]. "early saves may not have
- active hand or thumbnail"
-
fd := aDirectory directoryNamed: self resourceDirectoryName.
fd assureExistence.
"Clean up resource references before writing out"
mgr := self resourceManager.
self resourceManager: nil.
ResourceCollector current: ResourceCollector new.
ResourceCollector current localDirectory: fd.
ResourceCollector current baseUrl: self resourceUrl.
ResourceCollector current initializeFrom: mgr.
ProgressNotification signal: '2:findingResources' extra:
'(collecting resources...)' translated.
"Must activate old world because this is run at #armsLength.
Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent
will not be captured correctly if referenced from blocks or user code."
+ world becomeActiveDuring:
+ [is := ImageSegment copySmartRootsExport: roots asArray.
+ "old way was (is := ImageSegment new copyFromRootsForExport: roots asArray)"].
- world becomeActiveDuring:[
- is := ImageSegment copySmartRootsExport: roots asArray.
- "old way was (is := ImageSegment new
- copyFromRootsForExport: roots asArray)"
- ].
self resourceManager: mgr.
collector := ResourceCollector current.
ResourceCollector current: nil.
ProgressNotification signal: '2:foundResources' extra: ''.
+ is state = #tooBig ifTrue:
+ [collector replaceAll.
- is state = #tooBig ifTrue: [
- collector replaceAll.
^ false].
str := ''.
"considered legal to save a project that has never been entered"
+ (is outPointers includes: world) ifTrue:
+ [str := str, '\Project''s own world is not in the segment.' translated withCRs].
+ str isEmpty ifFalse:
+ [ans := Project uiManager
+ chooseOptionFrom:
+ {'Do not write file' translated.
+ 'Write file anyway' translated.
+ 'Debug' translated}
+ title: str.
+ ans = 1 ifTrue:
+ [revertSeg ifNotNil:
+ [projectParameters at: #revertToMe put: revertSeg].
- (is outPointers includes: world) ifTrue: [
- str := str, '\Project''s own world is not in the segment.' translated withCRs].
- str isEmpty ifFalse: [
- ans := UIManager default chooseFrom: {
- 'Do not write file' translated.
- 'Write file anyway' translated.
- 'Debug' translated.
- } title: str.
- ans = 1 ifTrue: [
- revertSeg ifNotNil: [projectParameters at:
- #revertToMe put: revertSeg].
collector replaceAll.
^ false].
+ ans = 3 ifTrue:
+ [collector replaceAll.
- ans = 3 ifTrue: [
- collector replaceAll.
self halt: 'Segment not written' translated]].
stacks := is findStacks.
is
writeForExportWithSources: aFileName
inDirectory: fd
changeSet: aChangeSetOrNil.
SecurityManager default signFile: aFileName directory: fd.
"Compress all files and update check sums"
collector forgetObsolete.
self storeResourceList: collector in: fd.
self storeHtmlPageIn: fd.
self storeManifestFileIn: fd.
self writeStackText: stacks in: fd registerIn: collector.
"local proj.005.myStack.t"
+ self
+ compressFilesIn: fd
+ to: aFileName
+ in: aDirectory
+ resources: collector.
+ "also deletes the resource directory"
- self compressFilesIn: fd to: aFileName in: aDirectory
- resources: collector.
- "also deletes the resource directory"
"Now update everything that we know about"
mgr updateResourcesFrom: collector.
+ revertSeg ifNotNil:
+ [projectParameters at: #revertToMe put: revertSeg].
- revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
- holder.
-
collector replaceAll.
+ world flapTabs do:
+ [:ft |
+ (ft respondsTo: #unhibernate) ifTrue:
+ [ft unhibernate]].
+ is arrayOfRoots do:
+ [:obj |
+ obj isScriptEditorMorph ifTrue:
+ [obj unhibernate]].
-
- world flapTabs do: [:ft |
- (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
- is arrayOfRoots do: [:obj |
- obj isScriptEditorMorph ifTrue: [obj unhibernate]].
^ true
!
Item was changed:
----- Method: MorphicProject>>loadFromServer: (in category 'file in/out') -----
loadFromServer: newerAutomatically
"If a newer version of me is on the server, load it."
| pair resp server |
self assureIntegerVersion.
+ self isCurrentProject ifTrue: "exit, then do the command"
+ [^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated].
- self isCurrentProject ifTrue: ["exit, then do the command"
- ^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated
- ].
server := self tryToFindAServerWithMe ifNil: [^ nil].
pair := self class mostRecent: self name onServer: server.
+ pair first ifNil:
+ [^ self inform: ('can''t find file on server for {1}' translated format: {self name})].
+ self currentVersionNumber > pair second ifTrue:
+ [^ self inform: ('That server has an older version of the project.' translated)].
+ version = (Project parseProjectFileName: pair first) second
+ ifTrue: [resp := (Project uiManager
+ chooseOptionFrom:
+ { 'Reload anyway' translated. 'Cancel' translated withCRs}
+ title: 'The only changes are the ones you made here.' translated).
+ resp ~= 1 ifTrue: [^ nil]]
+ ifFalse: [newerAutomatically ifFalse:
+ [resp := Project uiManager
+ chooseOptionFrom: {'Load it' translated. 'Cancel' translated}
+ title: 'A newer version exists on the server.' translated.
+ resp ~= 1 ifTrue: [^ nil]]].
- pair first ifNil: [^ self inform: ('can''t find file on server for {1}' translated format: {self name})].
- self currentVersionNumber > pair second ifTrue: [
- ^ self inform: ('That server has an older version of the project.' translated)].
- version = (Project parseProjectFileName: pair first) second ifTrue: [
- resp := (UIManager default chooseFrom:
- (Array with: 'Reload anyway' translated
- with: 'Cancel' translated withCRs)
- title: 'The only changes are the ones you made here.' translated).
- resp ~= 1 ifTrue: [^ nil]
- ] ifFalse: [
- newerAutomatically ifFalse: [
- resp := (UIManager default
- chooseFrom: {'Load it' translated. 'Cancel' translated}
- title: 'A newer version exists on the server.' translated).
- resp ~= 1 ifTrue: [^ nil]
- ].
- ].
"let's avoid renaming the loaded change set since it will be replacing ours"
self projectParameters at: #loadingNewerVersion put: true.
ComplexProgressIndicator new
targetMorph: nil;
historyCategory: 'project loading';
+ withProgressDo:
+ [ProjectLoading
- withProgressDo: [
- ProjectLoading
installRemoteNamed: pair first
from: server
named: self name
+ in: parentProject]!
- in: parentProject
- ]!
Item was changed:
----- Method: PasteUpMorph>>checkCurrentHandForObjectToPaste (in category 'world state') -----
checkCurrentHandForObjectToPaste
| response |
self primaryHand pasteBuffer ifNil: [^self].
+ response := Project uiManager
+ chooseOptionFrom: #('Delete' 'Keep')
+ title: 'Hand is holding a Morph in its paste buffer:\' withCRs,
+ self primaryHand pasteBuffer printString.
+ response = 1 ifTrue:
+ [self primaryHand pasteBuffer: nil].
- response := UIManager default chooseFrom: #('Delete' 'Keep')
- title: 'Hand is holding a Morph in its paste buffer:\' withCRs,
- self primaryHand pasteBuffer printString.
- response = 1 ifTrue: [self primaryHand pasteBuffer: nil].
!
Item was changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
| choice |
project ifNil:[^self delete]. "no current project"
+ choice := Project uiManager
+ chooseOptionFrom:
+ {'yes - delete the window and the project' translated.
+ 'no - delete the window only' translated}
+ title: ('Do you really want to delete {1}
- choice := UIManager default chooseFrom: {
- 'yes - delete the window and the project' translated.
- 'no - delete the window only' translated
- } title: ('Do you really want to delete {1}
and all its content?' translated format: {project name printString}).
choice = 1 ifTrue:[^self expungeProject].
choice = 2 ifTrue:[^self delete].!
More information about the Squeak-dev
mailing list
|