[squeak-dev] The Trunk: MorphicExtras-tpr.313.mczcommits at source.squeak.org commits at source.squeak.orgTue Apr 19 18:49:28 UTC 2022
tim Rowledge uploaded a new version of MorphicExtras to project The Trunk: http://source.squeak.org/trunk/MorphicExtras-tpr.313.mcz ==================== Summary ==================== Name: MorphicExtras-tpr.313 Author: tpr Time: 19 April 2022, 11:49:23.741659 am UUID: f5182346-7fd5-4596-91a2-f62d10708411 Ancestors: MorphicExtras-mt.312 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 MorphicExtras-mt.312 =============== Item was changed: ----- Method: BookMorph>>printPSToFile (in category 'menus') ----- printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName := 'MyBook' translated asFileName. + fileName := Project uiManager - fileName := UIManager default saveFilenameRequest: 'Filename to save BookMorph' translated initialAnswer: fileName. fileName isEmptyOrNil ifTrue: [^ Beeper beep]. + (fileName endsWith: '.ps') ifFalse: + [fileName := fileName,'.ps']. + rotateFlag := (Project uiManager + chooseOptionFrom: {'portrait (tall)' translated. 'landscape (wide)' translated} + title: 'Choose orientation...' translated) = 2. + FileStream + newFileNamed: fileName + do: + [:file| + file nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag)]! - (fileName endsWith: '.ps') ifFalse: [fileName := fileName,'.ps']. - - rotateFlag := (UIManager default chooseFrom: { - 'portrait (tall)' translated. - 'landscape (wide)' translated - } title: 'Choose orientation...' translated) = 2. - - FileStream newFileNamed: fileName do: [:file| - file nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag)]! Item was changed: ----- Method: BookMorph>>saveOnUrlPage: (in category 'menu') ----- saveOnUrlPage: pageMorph "Write out this single page in this book onto a server. See savePagesOnURL. (Don't compute the texts, only this page's is written.)" | stem ind response rand newPlace dir | + (self valueOfProperty: #keepTogether) ifNotNil: + [self inform: 'This book is marked ''keep in one file''. - (self valueOfProperty: #keepTogether) ifNotNil: [ - self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.' translated. ^ self]. "Don't give the chance to put in a different place. Assume named by number" + ((self valueOfProperty: #url) isNil and: [pages first url notNil]) ifTrue: + [response := Project uiManager + chooseOptionFrom: {'Old book' translated. 'New book sharing old pages' translated} + title: 'Modify the old book, or make a new + book sharing its pages?' translated. + response = 2 ifTrue: + ["Make up new url for .bo file and confirm with user." "Mark as shared" - ((self valueOfProperty: #url) isNil and: [pages first url notNil]) ifTrue: [ - response := UIManager default chooseFrom: { - 'Old book' translated. - 'New book sharing old pages' translated - } title: 'Modify the old book, or make a new - book sharing its pages?' translated. - response = 2 ifTrue: [ - "Make up new url for .bo file and confirm with user." "Mark as shared" [rand := String new: 4. + 1 to: rand size do: + [:ii | - 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. + (newPlace := self getStemUrl) ifEmpty: [^ self]. - (newPlace := self getStemUrl) isEmpty ifTrue: [^ self]. newPlace := (newPlace copyUpToLast: $/), '/BK', rand, '.bo'. dir := ServerFile new fullPath: newPlace. (dir includesKey: dir fileName)] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace]. response = 0 ifTrue: [^ self]]. stem := self getStemUrl. "user must approve" + stem ifEmpty: [^ self]. - stem isEmpty ifTrue: [^ self]. ind := pages identityIndexOf: pageMorph ifAbsent: [self error: 'where is the page?' translated]. + pageMorph isInMemory ifTrue: "not out now" + [pageMorph saveOnURL: stem,(ind printString),'.sp']. - pageMorph isInMemory ifTrue: ["not out now" - pageMorph saveOnURL: stem,(ind printString),'.sp']. self saveIndexOfOnly: pageMorph.! Item was changed: ----- Method: BookMorph>>savePagesOnURL (in category 'menu') ----- savePagesOnURL "Write out all pages in this book onto a server. For any page that does not have a SqueakPage and a url already, ask the user for one. Give the option of naming all page files by page number. Any pages that are not in memory will stay that way. The local disk could be the server." | response list firstTime newPlace rand dir bookUrl | + (self valueOfProperty: #keepTogether) ifNotNil: + [self inform: 'This book is marked ''keep in one file''. - (self valueOfProperty: #keepTogether) ifNotNil: [ - self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.' translated. ^ self]. self getAllText. "stored with index later" + response := Project uiManager + chooseOptionFrom: + {'Use page numbers' translated. + 'Type in file names' translated. + 'Save in a new place (using page numbers)' translated. + 'Save in a new place (typing names)' translated. + 'Save new book sharing old pages' translated. } + title: 'Each page will be a file on the server. - response := UIManager default chooseFrom: { - 'Use page numbers' translated. - 'Type in file names' translated. - 'Save in a new place (using page numbers)' translated. - 'Save in a new place (typing names)' translated. - 'Save new book sharing old pages' translated. - } title: 'Each page will be a file on the server. Do you want to page numbers be the names of the files? or name each one yourself?' translated. response = 1 ifTrue: [self saveAsNumberedURLs. ^ self]. response = 3 ifTrue: [self forgetURLs; saveAsNumberedURLs. ^ self]. response = 4 ifTrue: [self forgetURLs]. + response = 5 ifTrue: + ["Make up new url for .bo file and confirm with user." "Mark as shared" - response = 5 ifTrue: [ - "Make up new url for .bo file and confirm with user." "Mark as shared" [rand := String new: 4. 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. (newPlace := self getStemUrl) isEmpty ifTrue: [^ self]. newPlace := (newPlace copyUpToLast: $/), '/BK', rand, '.bo'. dir := ServerFile new fullPath: newPlace. (dir includesKey: dir fileName)] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace. self saveAsNumberedURLs. bookUrl := self valueOfProperty: #url. + (SqueakPage stemUrl: bookUrl) = (SqueakPage stemUrl: currentPage url) ifTrue: + [bookUrl := true]. "not a shared book" - (SqueakPage stemUrl: bookUrl) = - (SqueakPage stemUrl: currentPage url) ifTrue: [ - bookUrl := true]. "not a shared book" (URLMorph grabURL: currentPage url) book: bookUrl. ^ self]. response = 0 ifTrue: [^ self]. + "self reserveUrlsIfNeeded. Need two passes here -- name on one, write on second" + pages do: + [:aPage | "does write the current page too" + aPage isInMemory ifTrue: "not out now" + [aPage presenter ifNotNil: + [aPage presenter flushPlayerListCache]. + aPage saveOnURLbasic]]. "ask user if no url" - "self reserveUrlsIfNeeded. Need two passes here -- name on one, write on second" - pages do: [:aPage | "does write the current page too" - aPage isInMemory ifTrue: ["not out now" - aPage presenter ifNotNil: [aPage presenter flushPlayerListCache]. - aPage saveOnURLbasic. - ]]. "ask user if no url" + list := pages collect: + [:aPage | + aPage sqkPage prePurge]. "knows not to purge the current page" + list := (list select: [:each | each notNil]) asArray. + "do bulk become:" + (list collect: + [:each | + each contentsMorph]) + elementsExchangeIdentityWith: (list collect: + [:spg | + MorphObjectOut new xxxSetUrl: spg url page: spg]). - list := pages collect: [:aPage | aPage sqkPage prePurge]. - "knows not to purge the current page" - list := (list select: [:each | each notNil]) asArray. - "do bulk become:" - (list collect: [:each | each contentsMorph]) - elementsExchangeIdentityWith: - (list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]). + firstTime := (self valueOfProperty: #url) isNil. + self saveIndexOnURL. + self presenter ifNotNil: + [self presenter flushPlayerListCache]. + firstTime ifTrue: "Put a thumbnail into the hand" + [URLMorph grabForBook: self. + self setProperty: #futureUrl toValue: nil]. "clean up" - firstTime := (self valueOfProperty: #url) isNil. - self saveIndexOnURL. - self presenter ifNotNil: [self presenter flushPlayerListCache]. - firstTime ifTrue: ["Put a thumbnail into the hand" - URLMorph grabForBook: self. - self setProperty: #futureUrl toValue: nil]. "clean up" ! Item was changed: ----- Method: FlapTab>>dismissViaHalo (in category 'submorphs - add/remove') ----- dismissViaHalo "Dismiss the receiver (and its referent), unless it resists" self resistsRemoval ifTrue: + [(Project uiManager + chooseOptionFrom: #( 'Yes' 'Um, no, let me reconsider') + title: 'Really throw this flap away?') = 2 ifFalse: [^ self]]. - [(UIManager default chooseFrom: #( 'Yes' 'Um, no, let me reconsider') - title: 'Really throw this flap away?') = 2 ifFalse: [^ self]]. - referent delete. self delete! Item was changed: ----- Method: Morph>>printPSToFileNamed: (in category '*MorphicExtras-menus') ----- printPSToFileNamed: aString "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag psCanvasType psExtension | psCanvasType := PostscriptCanvas defaultCanvasType. psExtension := psCanvasType defaultExtension. fileName := UIManager default saveFilenameRequest: 'File name? ' initialAnswer: (aString, psExtension) asFileName. fileName ifNil: [^ Beeper beep]. + rotateFlag := (UIManager default chooseOptionFrom: { - rotateFlag := (UIManager default chooseFrom: { 'portrait (tall)' translated. 'landscape (wide)' translated. } title: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName) nextPutAll: (psCanvasType morphAsPostscript: self rotated: rotateFlag); close! Item was changed: ----- Method: MorphObjectOut>>doesNotUnderstand: (in category 'error handling') ----- doesNotUnderstand: aMessage "Bring in the object, install, then resend aMessage" | aMorph myUrl oldFlag response | "Transcript show: thisContext sender selector; cr." "useful for debugging" oldFlag := recursionFlag. recursionFlag := true. myUrl := url. "can't use inst vars after become" "fetch the object" aMorph := self xxxFetch. "watch out for the become!!" + "Now we ARE a MORPH" + oldFlag == true ifTrue: + [response := Project uiManager + chooseOptionFrom: #('proceed normally' 'debug') + title: 'Object being fetched for a second time. - "Now we ARE a MORPH" - oldFlag == true ifTrue: [ - response := UIManager default chooseFrom: #('proceed normally' 'debug') - title: 'Object being fetched for a second time. Should not happen, and needs to be fixed later.'. response = 2 ifTrue: [self halt]]. "We are already the new object" + aMorph setProperty: #SqueakPage toValue: (SqueakPageCache pageCache at: myUrl). - aMorph setProperty: #SqueakPage toValue: - (SqueakPageCache pageCache at: myUrl). "Can't be a super message, since this is the first message sent to this object" ^ aMorph perform: aMessage selector withArguments: aMessage arguments ! Item was changed: ----- Method: ObjectOut>>doesNotUnderstand: (in category 'error handling') ----- doesNotUnderstand: aMessage "Bring in the object, install, then resend aMessage" | realObject oldFlag response | oldFlag := recursionFlag. recursionFlag := true. "fetch the object" realObject := self xxxFetch. "watch out for the become!!" + "Now we ARE the realObject" + oldFlag == true ifTrue: + [response := (Project uiManager + chooseOptionFrom: #('proceed normally' 'debug') + title: 'Object being fetched for a second time. - "Now we ARE the realObject" - oldFlag == true ifTrue: [ - response := (UIManager default chooseFrom: #('proceed normally' 'debug') - title: 'Object being fetched for a second time. Should not happen, and needs to be fixed later.'). response = 2 ifTrue: [self halt]]. "We are already the new object" "Can't be a super message, since this is the first message sent to this object" ^ realObject perform: aMessage selector withArguments: aMessage arguments! Item was changed: ----- Method: ProjectNavigationMorph>>findSomethingOnSuperSwiki (in category 'the buttons') ----- findSomethingOnSuperSwiki | projectServers server index | projectServers := ServerDirectory projectServers. projectServers isEmpty ifTrue: [^self]. projectServers size = 1 ifTrue: [server := projectServers first] + ifFalse: [index := Project uiManager + chooseOptionFrom: (projectServers collect: [:each | (ServerDirectory nameForServer: each) translatedIfCorresponds]) + title: 'Choose a super swiki:' translated. - ifFalse: [index := UIManager default chooseFrom: (projectServers collect: [:each | (ServerDirectory nameForServer: each) translatedIfCorresponds]) - title: 'Choose a super swiki:' translated. index > 0 ifTrue: [server := projectServers at: index] ifFalse: [^self]]. Smalltalk at: #EToyProjectQueryMorph ifPresent:[:aClass| aClass onServer: server].! Item was changed: ----- Method: SketchEditorMorph>>deliverPainting:evt: (in category 'start & finish') ----- deliverPainting: result evt: evt "Done painting. May come from resume, or from original call. Execute user's post painting instructions in the block. Always use this standard one. 4/21/97 tk" | newBox newForm ans | palette ifNotNil: "nil happens" [palette setAction: #paint: evt: evt]. "Get out of odd modes" "rot := palette getRotations." "rotate with heading, or turn to and fro" "palette setRotation: #normal." result == #cancel ifTrue: [ + ans := Project uiManager + chooseOptionFrom: + { 'throw it away' translated. + 'keep painting it' translated} + title: 'Do you really want to throw away - ans := UIManager default chooseFrom: { - 'throw it away' translated. - 'keep painting it' translated. - } title: 'Do you really want to throw away what you just painted?' translated. + ^ ans = 1 + ifTrue: [self cancelOutOfPainting] + ifFalse: [nil]]. "cancelled out of cancelling." - ^ ans = 1 ifTrue: [self cancelOutOfPainting] - ifFalse: [nil]]. "cancelled out of cancelling." "hostView rotationStyle: rot." "rotate with heading, or turn to and fro" newBox := paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent. registrationPoint ifNotNil: [registrationPoint := registrationPoint - newBox origin]. "relative to newForm origin" newForm := Form extent: newBox extent depth: paintingForm depth. newForm copyBits: newBox from: paintingForm at: 0 at 0 clippingBox: newForm boundingBox rule: Form over fillColor: nil. + newForm isAllWhite ifTrue: + [(self valueOfProperty: #background) == true ifFalse: + [^ self cancelOutOfPainting]]. - newForm isAllWhite ifTrue: [ - (self valueOfProperty: #background) == true - ifFalse: [^ self cancelOutOfPainting]]. newForm fixAlpha. "so alpha channel stays intact for 32bpp" self delete. "so won't find me again" + dimForm ifNotNil: + [dimForm delete]. - dimForm ifNotNil: [dimForm delete]. newPicBlock value: newForm value: (newBox copy translateBy: bounds origin). Project current world resumeScriptsPausedByPainting.!
More information about the Squeak-dev mailing list |