'From Squeak3.8gamma of ''24 November 2004'' [latest update: #6548] on 19 February 2005 at 10:42:17 am'! !ArchiveViewer methodsFor: 'archive operations' stamp: 'rbb 2/18/2005 13:32'! extractAllPossibleInDirectory: directory "Answer true if I can extract all the files in the given directory safely. Inform the user as to problems." | conflicts | self canExtractAll ifFalse: [ ^false ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory fullNameFor: ea localFileName. (ea usesFileNamed: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) are needed by archive members and cannot be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. self inform: str contents. ^false. ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory relativeNameFor: ea localFileName. (directory fileExists: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) will be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. str cr; nextPutAll: 'Is this OK?'. ^self confirm: str contents. ]. ^true. ! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'rbb 2/18/2005 13:33'! changeViewAllContents (viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]]) ifTrue: [ (self confirm: 'This member''s size is ', (self selectedMember uncompressedSize asString), '; do you really want to see all that data?') ifFalse: [ ^self ] ]. viewAllContents _ viewAllContents not. self changed: #contents! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:15'! askAddedInstVars: classList | pairList pairClasses index pls newStruct oldStruct | "Ask the author whether these newly added inst vars need to be non-nil" pairList _ OrderedCollection new. pairClasses _ OrderedCollection new. "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." classList do: [:cls | newStruct _ (cls allInstVarNames). oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. newStruct do: [:instVarName | (oldStruct includes: instVarName) ifFalse: [ pairList add: cls name, ' ', instVarName. pairClasses add: cls]]]. pairList isEmpty ifTrue: [^ #()]. [index _ UIManager default chooseFrom: pairList, #('all of these need a non-nil value' 'all of these are OK with a nil value') title: 'These instance variables were added. When an old project comes in, newly added instance variables will have the value nil. Click on items to remove them from the list. Click on any for which nil is an OK value.' . (index <= (pls _ pairList size)) & (index > 0) ifTrue: [ pairList removeAt: index. pairClasses removeAt: index]. index = (pls + 2) ifTrue: ["all are OK" ^ #()]. pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. ^ pairClasses asSet asArray "non redundant"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:17'! askRemovedInstVars: classList | pairList pairClasses index pls newStruct oldStruct | "Ask the author whether these newly removed inst vars need to have their info saved" pairList _ OrderedCollection new. pairClasses _ OrderedCollection new. "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." classList do: [:cls | newStruct _ (cls allInstVarNames). oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. oldStruct do: [:instVarName | (newStruct includes: instVarName) ifFalse: [ pairList add: cls name, ' ', instVarName. pairClasses add: cls]]]. pairList isEmpty ifTrue: [^ #()]. [index _ UIManager default chooseFrom: pairList, #('all of these need a conversion method' 'all of these have old values that can be erased') title: 'These instance variables were removed. When an old project comes in, instance variables that have been removed will lose their contents. Click on items to remove them from the list. Click on any whose value is unimportant and need not be saved.'. (index <= (pls _ pairList size)) & (index > 0) ifTrue: [ pairList removeAt: index. pairClasses removeAt: index]. index = (pls + 2) ifTrue: ["all are OK" ^ #()]. pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. ^ pairClasses asSet asArray "non redundant"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:18'! askRenames: renamed addTo: msgSet using: smart | list rec ans oldStruct newStruct | "Go through the renamed classes. Ask the user if it could be in a project. Add a method in SmartRefStream, and a conversion method in the new class." list _ OrderedCollection new. renamed do: [:cls | rec _ changeRecords at: cls name. rec priorName ifNotNil: [ ans _ UIManager default chooseFrom: #('Yes, write code to convert those instances' 'No, no instances are in projects') title: 'You renamed class ', rec priorName, ' to be ', rec thisName, '.\Could an instance of ', rec priorName, ' be in a project on someone''s disk?'. ans = 1 ifTrue: [ oldStruct _ structures at: rec priorName ifAbsent: [nil]. newStruct _ (Array with: cls classVersion), (cls allInstVarNames). oldStruct ifNotNil: [ smart writeConversionMethodIn: cls fromInstVars: oldStruct to: newStruct renamedFrom: rec priorName. smart writeClassRename: cls name was: rec priorName. list add: cls name, ' convertToCurrentVersion:refStream:']] ifFalse: [structures removeKey: rec priorName ifAbsent: []]]]. list isEmpty ifTrue: [^ msgSet]. msgSet messageList ifNil: [msgSet initializeMessageList: list] ifNotNil: [list do: [:item | msgSet addItem: item]]. ^ msgSet! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:20'! checkForConversionMethods "See if any conversion methods are needed" | oldStruct newStruct tell choice list need sel smart restore renamed listAdd listDrop msgSet rec nn | Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference" structures ifNil: [^ self]. list _ OrderedCollection new. renamed _ OrderedCollection new. self changedClasses do: [:class | need _ (self atClass: class includes: #new) not. need ifTrue: ["Renamed classes." (self atClass: class includes: #rename) ifTrue: [ rec _ changeRecords at: class name. rec priorName ifNotNil: [ (structures includesKey: rec priorName) ifTrue: [ renamed add: class. need _ false]]]]. need ifTrue: [need _ (self atClass: class includes: #change)]. need ifTrue: [oldStruct _ structures at: class name ifAbsent: [need _ false. #()]]. need ifTrue: [ newStruct _ (Array with: class classVersion), (class allInstVarNames). need _ (oldStruct ~= newStruct)]. need ifTrue: [sel _ #convertToCurrentVersion:refStream:. (#(add change) includes: (self atSelector: sel class: class)) ifFalse: [ list add: class]]. ]. list isEmpty & renamed isEmpty ifTrue: [^ self]. "Ask user if want to do this" tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString, '\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\' withCRs, 'After you edit the conversion method, you''ll need to fileOut again.\' withCRs, 'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'. choice _ (UIManager default chooseFrom: #('Write a conversion method by editing a prototype' 'These classes are not used in any object file. fileOut my changes now.' 'I''m too busy. fileOut my changes now.' 'Don''t ever ask again. fileOut my changes now.') title: tell). choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut]. choice = 2 ifTrue: ["Don't consider this class again in the changeSet" list do: [:cls | structures removeKey: cls name ifAbsent: []]. renamed do: [:cls | nn _ (changeRecords at: cls name) priorName. structures removeKey: nn ifAbsent: []]]. choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4" listAdd _ self askAddedInstVars: list. "Go through each inst var that was added" listDrop _ self askRemovedInstVars: list. "Go through each inst var that was removed" list _ (listAdd, listDrop) asSet asArray. smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345'). smart structures: structures. smart superclasses: superclasses. (restore _ self class current) == self ifFalse: [ self class newChanges: self]. "if not current one" msgSet _ smart conversionMethodsFor: list. "each new method is added to self (a changeSet). Then filed out with the rest." self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods" restore == self ifFalse: [self class newChanges: restore]. msgSet messageList isEmpty ifTrue: [^ self]. self inform: 'Remember to fileOut again after modifying these methods.'. MessageSet open: msgSet name: 'Conversion methods for ', self name.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:21'! chooseSubjectPrefixForEmail | subjectIndex | subjectIndex _ (UIManager default chooseFrom: #('Bug fix [FIX]' 'Enhancement [ENH]' 'Goodie [GOODIE]' 'Test suite [TEST]' 'None of the above (will not be archived)') title: 'What type of change set\are you submitting to the list?' withCRs). ^ #('[CS] ' '[FIX] ' '[ENH] ' '[GOODIE] ' '[TEST] ' '[CS] ') at: subjectIndex + 1! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:14'! fileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" | slips nameToUse internalStream | self checkForConversionMethods. ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. nameToUse := Preferences changeSetVersionNumbers ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: FileStream cs] ifFalse: [self name , FileDirectory dot , Utilities dateTimeSuffix, FileDirectory dot , FileStream cs]. (Preferences warningForMacOSFileNameLength and: [nameToUse size > 30]) ifTrue: [nameToUse := FillInTheBlank request: (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo: 30). nameToUse = '' ifTrue: [^ self]]. nameToUse := self defaultChangeSetDirectory fullNameFor: nameToUse. Cursor write showWhile: [ internalStream _ WriteStream on: (String new: 10000). internalStream header; timeStamp. self fileOutPreambleOn: internalStream. self fileOutOn: internalStream. self fileOutPostscriptOn: internalStream. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: (nameToUse copyFrom: 1 to: nameToUse size - 3) isSt: false useHtml: false. ]. Preferences checkForSlips ifFalse: [^ self]. slips := self checkForSlips. (slips size > 0 and: [(UIManager default chooseFrom: #('Ignore' 'Browse slips') title: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?' ) = 2]) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:16'! lookForSlips "Scan the receiver for changes that the user may regard as slips to be remedied" | slips nameLine msg | nameLine _ ' "', self name, '" '. (slips _ self checkForSlips) size == 0 ifTrue: [^ self inform: 'No slips detected in change set', nameLine]. msg _ slips size == 1 ifTrue: [ 'One method in change set', nameLine, 'has a halt, reference to the Transcript, and/or some other ''slip'' in it. Would you like to browse it? ?'] ifFalse: [ slips size printString, ' methods in change set', nameLine, 'have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']. (UIManager default chooseFrom: #('Ignore' 'Browse slips') title: msg) = 2 ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ', name]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'rbb 2/18/2005 11:25'! chooseClassVarName "Present the user with a list of class variable names and answer the one selected, or nil if none" | lines labelStream vars allVars index | lines _ OrderedCollection new. allVars _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (UIManager default chooseFrom: (labelStream contents substrings) lines: lines). index = 0 ifTrue: [^ nil]. ^ allVars at: index! ! !ClassDescription methodsFor: 'instance variables' stamp: 'rbb 2/18/2005 11:31'! chooseInstVarAlphabeticallyThenDo: aBlock | allVars index | "Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." allVars _ self allInstVarNames asSortedArray. allVars isEmpty ifTrue: [^ self inform: 'There are no instance variables']. index _ (UIManager default chooseFrom: allVars lines: #() title: 'Instance variables in ', self name). index = 0 ifTrue: [^ self]. aBlock value: (allVars at: index)! ! !ClassDescription methodsFor: 'instance variables' stamp: 'rbb 2/18/2005 11:29'! chooseInstVarThenDo: aBlock "Put up a menu of all the instance variables in the receiver, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter. If the list is 6 or larger, then offer an alphabetical formulation as an alternative. triggered by a 'show alphabetically' item at the top of the list." | lines labelStream vars allVars index count offerAlpha | (count _ self allInstVarNames size) = 0 ifTrue: [^ self inform: 'There are no instance variables.']. allVars _ OrderedCollection new. lines _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). (offerAlpha _ count > 5) ifTrue: [lines add: 1. allVars add: 'show alphabetically'. labelStream nextPutAll: allVars first; cr]. self withAllSuperclasses reverseDo: [:class | vars _ class instVarNames. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream skip: -1 "cut last CR". (lines size > 0 and: [lines last = allVars size]) ifTrue: [lines removeLast]. "dispense with inelegant line beneath last item" index _ (UIManager default chooseFrom: (labelStream contents substrings) lines: lines title: 'Instance variables in', self name). index = 0 ifTrue: [^ self]. (index = 1 and: [offerAlpha]) ifTrue: [^ self chooseInstVarAlphabeticallyThenDo: aBlock]. aBlock value: (allVars at: index)! ! !AutoStart class methodsFor: 'updating' stamp: 'rbb 2/18/2005 13:25'! processUpdates "Process update files from a well-known update server. This method is called at system startup time, Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically" | choice | (Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue: [choice _ UIManager default chooseFrom: #('Yes, Update' 'No, Not now') title: 'Shall I look for new code\updates on the server?' withCRs. choice = 1 ifTrue: [Utilities updateFromServer]]. ^false! ! !ChangeSet class methodsFor: 'defaults' stamp: 'rbb 2/18/2005 13:19'! promptForDefaultChangeSetDirectoryIfNecessary "Check the Preference (if any), and prompt the user to change it if necessary. The default if the Preference is unset is the current directory. Answer the directory." "ChangeSet promptForDefaultChangeSetDirectoryIfNecessary" | choice directoryName dir | directoryName := Preferences parameterAt: #defaultChangeSetDirectoryName ifAbsentPut: ['']. [dir := FileDirectory default directoryNamed: directoryName. dir exists] whileFalse: [choice := UIManager default chooseFrom: (#('Create directory' 'Use default directory and forget preference' 'Choose another directory' ) collect: [ :ea | ea translated ]) title: ('The preferred change set directory (''{1}'') does not exist. Create it or use the default directory ({2})?' translated format: { directoryName. FileDirectory default pathName }). choice = 1 ifTrue: [dir assureExistence ]. choice = 3 ifTrue: [dir := FileList2 modalFolderSelector. directoryName := dir ifNil: [ '' ] ifNotNil: [dir pathName ]]]. self defaultChangeSetDirectory: directoryName. ^dir! ! !CodeHolder methodsFor: 'categories' stamp: 'rbb 2/16/2005 17:01'! categoryFromUserWithPrompt: aPrompt for: aClass "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" | labels myCategories reject lines cats newName menuIndex | labels _ OrderedCollection with: 'new...'. labels addAll: (myCategories _ aClass organization categories asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject _ myCategories asSet. reject add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines _ OrderedCollection with: 1 with: (myCategories size + 1). aClass allSuperclasses do: [:cls | cats _ cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [lines add: labels size. labels addAll: (cats asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject addAll: cats]]. newName _ (labels size = 1 or: [menuIndex _ (UIManager default chooseFrom: labels lines: lines) startUpWithCaption: aPrompt. menuIndex = 0 ifTrue: [^ nil]. menuIndex = 1]) ifTrue: [FillInTheBlank request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [labels at: menuIndex]. ^ newName ifNotNil: [newName asSymbol]! ! !Browser methodsFor: 'message category functions' stamp: 'rbb 2/16/2005 17:01'! addCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | labels reject lines cats menuIndex oldIndex newName | self okToChange ifFalse: [^ self]. classListIndex = 0 ifTrue: [^ self]. labels _ OrderedCollection with: 'new...'. reject _ Set new. reject addAll: self selectedClassOrMetaClass organization categories; add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines _ OrderedCollection new. self selectedClassOrMetaClass allSuperclasses do: [:cls | cls = Object ifFalse: [ cats _ cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [ lines add: labels size. labels addAll: cats asSortedCollection. reject addAll: cats]]]. newName _ (labels size = 1 or: [ menuIndex _ (UIManager default chooseFrom: labels lines: lines) startUpWithCaption: 'Add Category'. menuIndex = 0 ifTrue: [^ self]. menuIndex = 1]) ifTrue: [ self request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [ labels at: menuIndex]. oldIndex _ messageCategoryListIndex. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. self classOrMetaClassOrganizer addCategory: newName before: (messageCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedMessageCategoryName]). self changed: #messageCategoryList. self messageCategoryListIndex: (oldIndex = 0 ifTrue: [self classOrMetaClassOrganizer categories size + 1] ifFalse: [oldIndex]). self changed: #messageCategoryList. ! ! !Browser methodsFor: 'system category functions' stamp: 'rbb 2/16/2005 17:02'! findClass "Search for a class by name." | pattern foundClass classNames index toMatch exactMatch potentialClassNames | self okToChange ifFalse: [^ self classNotFound]. pattern _ FillInTheBlank request: 'Class name or fragment?'. pattern isEmpty ifTrue: [^ self classNotFound]. toMatch _ (pattern copyWithout: $.) asLowercase. potentialClassNames _ self potentialClassNames asOrderedCollection. classNames _ pattern last = $. ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. classNames isEmpty ifTrue: [^ self classNotFound]. exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil]. index _ classNames size = 1 ifTrue: [1] ifFalse: [exactMatch ifNil: [(UIManager default chooseFrom: classNames lines: #()) ] ifNotNil: [classNames addFirst: exactMatch. (UIManager default chooseFrom: classNames lines: #(1))]]. index = 0 ifTrue: [^ self classNotFound]. foundClass _ Smalltalk at: (classNames at: index) asSymbol. self selectCategoryForClass: foundClass. self selectClass: foundClass ! ! !ChangeList methodsFor: 'menu actions' stamp: 'rbb 2/18/2005 10:10'! selectConflictsWith "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk" | aStream all index | aStream _ WriteStream on: (String new: 200). (all _ ChangeSorter allChangeSets copy) do: [:sel | aStream nextPutAll: (sel name contractTo: 40); cr]. ChangeList allSubInstancesDo: [:sel | aStream nextPutAll: (sel file name); cr. all addLast: sel]. aStream skip: -1. index _ (UIManager default chooseFrom: (aStream contents substrings)). index > 0 ifTrue: [ self selectConflicts: (all at: index)]. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'rbb 2/18/2005 10:38'! findCngSet "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates nameList | self okToChange ifFalse: [^ self]. pattern _ FillInTheBlank request: 'ChangeSet name or fragment?'. pattern isEmpty ifTrue: [^ self]. nameList _ self changeSetList asSet. candidates _ AllChangeSets select: [:c | (nameList includes: c name) and: [c name includesSubstring: pattern caseSensitive: false]]. candidates size = 0 ifTrue: [^ Beeper beep]. candidates size = 1 ifTrue: [^ self showChangeSet: candidates first]. index _ (UIManager default chooseFrom: (candidates collect: [:each | each name])). index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. ! ! !ChangeSorter class methodsFor: 'services' stamp: 'rbb 2/18/2005 11:37'! browseChangeSetsWithClass: class selector: selector "Put up a menu comprising a list of change sets that hold changes for the given class and selector. If the user selects one, open a single change-sorter onto it" | hits index | hits _ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ self inform: class name, '.', selector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name]) lines: #())]. index = 0 ifTrue: [^ self]. (ChangeSorter new myChangeSet: (hits at: index)) open. ! ! !ChangeSorter class methodsFor: 'services' stamp: 'rbb 2/18/2005 12:11'! browseChangeSetsWithSelector: aSelector "Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector" | hits index | hits _ self allChangeSets select: [:cs | cs hasAnyChangeForSelector: aSelector]. hits isEmpty ifTrue: [^ self inform: aSelector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name]) lines: #())]. index = 0 ifTrue: [^ self]. (ChangeSetBrowser new myChangeSet: (hits at: index)) open "ChangeSorter browseChangeSetsWithSelector: #clearPenTrails" ! ! !ComponentLikeModel methodsFor: 'submorphs-add/remove' stamp: 'rbb 2/18/2005 13:32'! delete "Delete the receiver. Possibly put up confirming dialog. Abort if user changes mind" (model isKindOf: Component) ifTrue: [^self deleteComponent]. (model isMorphicModel) ifFalse: [^super delete]. slotName ifNotNil: [(self confirm: 'Shall I remove the slot ' , slotName , ' along with all associated methods?') ifTrue: [(model class selectors select: [:s | s beginsWith: slotName]) do: [:s | model class removeSelector: s]. (model class instVarNames includes: slotName) ifTrue: [model class removeInstVarName: slotName]] ifFalse: [(self confirm: '...but should I at least dismiss this morph? [choose no to leave everything unchanged]') ifFalse: [^self]]]. super delete! ! !ControlManager methodsFor: 'scheduling' stamp: 'rbb 2/18/2005 10:50'! findWindowSatisfying: aBlock "Present a menu of window titles, and activate the one that gets chosen" | sortAlphabetically controllers listToUse labels index | sortAlphabetically _ Sensor shiftPressed. controllers _ OrderedCollection new. scheduledControllers do: [:controller | controller == screenController ifFalse: [(aBlock value: controller) ifTrue: [controllers addLast: controller]]]. controllers size == 0 ifTrue: [^ self]. listToUse _ sortAlphabetically ifTrue: [controllers asSortedCollection: [:a :b | a view label < b view label]] ifFalse: [controllers]. labels _ String streamContents: [:strm | listToUse do: [:controller | strm nextPutAll: (controller view label contractTo: 40); cr]. strm skip: -1 "drop last cr"]. index _ (UIManager default chooseFrom: (labels findTokens: Character cr) asArray). index > 0 ifTrue: [self activateController: (listToUse at: index)]. ! ! !ControlManager methodsFor: 'scheduling' stamp: 'rbb 2/18/2005 10:52'! windowFromUser "Present a menu of window titles, and returns the StandardSystemController belonging to the one that gets chosen, or nil if none" | controllers labels index | controllers _ OrderedCollection new. labels _ String streamContents: [:strm | scheduledControllers do: [:controller | controller == screenController ifFalse: [controllers addLast: controller. strm nextPutAll: (controller view label contractTo: 40); cr]]. strm skip: -1 "drop last cr"]. index _ (UIManager default chooseFrom: (labels findTokens: Character cr) asArray). ^ index > 0 ifTrue: [controllers at: index] ifFalse: [nil]! ! !Debugger methodsFor: 'context stack menu' stamp: 'rbb 2/16/2005 17:10'! askForCategoryIn: aClass default: aString | categories index category | categories := OrderedCollection with: 'new ...'. categories addAll: (aClass allMethodCategoriesIntegratedThrough: Object). index := UIManager default chooseFrom: categories title: 'Please provide a good category for the new method!!' translated. index = 0 ifTrue: [^ aString]. category := index = 1 ifTrue: [FillInTheBlank request: 'Enter category name:'] ifFalse: [categories at: index]. ^ category isEmpty ifTrue: [^ aString] ifFalse: [category]! ! !Debugger methodsFor: 'private' stamp: 'rbb 2/16/2005 17:11'! askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock | classes chosenClassIndex | classes _ aClass withAllSuperclasses. chosenClassIndex _ UIManager default chooseFrom: (classes collect: [:c | c name]) title: 'Define #', aSelector, ' in which class?'. chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. ^ classes at: chosenClassIndex! ! !DocLibrary methodsFor: 'doc pane' stamp: 'rbb 2/15/2005 21:31'! fetchDocSel: aSelector class: className "Look on servers to see if there is documentation pane for the selected message. Take into account the current update number. If not, ask the user if she wants to create a blank one." | key response docPane ext | key _ aSelector size = 0 ifFalse: [className, ' ', aSelector] ifTrue: [className]. (self openDocAt: key) ifNil: [ response _ UIManager default chooseFrom: #('Create new page' 'Cancel') lines: #() title: ('No documentation exists for this method.\Would you like to write some?' withCRs). response = 1 ifTrue: [ docPane _ PasteUpMorph new. docPane color: Color white; borderWidth: 2; borderColor: Color green. docPane setProperty: #classAndMethod toValue: key. docPane setProperty: #initialExtent toValue: (ext _ 200@200). docPane topLeft: (RealEstateAgent initialFrameFor: docPane world: Smalltalk currentWorld) origin. docPane extent: ext. docPane addMorph: (TextMorph new topLeft: docPane topLeft + (10@10); extent: docPane width - 15 @ 30). Smalltalk currentWorld addMorph: docPane]]. "If found, openDocAt: put it on the screen"! ! !DocLibrary methodsFor: 'doc pane' stamp: 'rbb 2/15/2005 21:34'! saveDocCheck: aMorph "Make sure the document gets attached to the version of the code that the user was looking at. Is there a version of this method in a changeSet beyond the updates we know about? Works even when the user has internal update numbers and the documentation is for external updates (It always is)." | classAndMethod parts selector class lastUp beyond ours docFor unNum ok key verList ext response | classAndMethod _ aMorph valueOfProperty: #classAndMethod. classAndMethod ifNil: [ ^ self error: 'need to know the class and method']. "later let user set it" parts _ classAndMethod findTokens: ' .'. selector _ parts last asSymbol. class _ Smalltalk at: (parts first asSymbol) ifAbsent: [^ self saveDoc: aMorph]. parts size = 3 ifTrue: [class _ class class]. "Four indexes we are looking for: docFor = highest numbered below lastUpdate that has method. unNum = a higher unnumbered set that has method. lastUp = lastUpdate we know about in methodVersions beyond = any set about lastUp that has the method." ChangeSorter allChangeSets doWithIndex: [:cs :ind | "youngest first" (cs name includesSubString: lastUpdateName) ifTrue: [lastUp _ ind]. (cs atSelector: selector class: class) ~~ #none ifTrue: [ lastUp ifNotNil: [beyond _ ind. ours _ cs name] ifNil: [cs name first isDigit ifTrue: [docFor _ ind] ifFalse: [unNum _ ind. ours _ cs name]]]]. "See if version the user sees is the version he is documenting" ok _ beyond == nil. unNum ifNotNil: [docFor ifNotNil: [ok _ docFor > unNum] ifNil: [ok _ false]]. "old changeSets gone" ok ifTrue: [^ self saveDoc: aMorph]. key _ DocLibrary properStemFor: classAndMethod. verList _ (methodVersions at: key ifAbsent: [#()]), #(0 0). ext _ verList first. "external update number we will write to" response _ (UIManager default chooseFrom: #('Cancel' 'Broadcast Page') lines: #() title: 'You are documenting a method in External Update ', ext asString, '.\There is a more recent version of that method in ' withCRs, ours, '.\If you are explaining the newer version, please Cancel.\Wait until that version appears in an External Update.' withCRs). response = 2 ifTrue: [self saveDoc: aMorph]. ! ! !FileContentsBrowser methodsFor: 'class list' stamp: 'rbb 2/16/2005 17:02'! findClass | pattern foundClass classNames index foundPackage | self okToChange ifFalse: [^ self classNotFound]. pattern _ (FillInTheBlank request: 'Class Name?') asLowercase. pattern isEmpty ifTrue: [^ self]. classNames := Set new. self packages do:[:p| classNames addAll: p classes keys]. classNames := classNames asArray select: [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. classNames isEmpty ifTrue: [^ self]. index _ classNames size == 1 ifTrue: [1] ifFalse: [(UIManager default chooseFrom: classNames lines: #())]. index = 0 ifTrue: [^ self]. foundPackage := nil. foundClass := nil. self packages do:[:p| (p classes includesKey: (classNames at: index)) ifTrue:[ foundClass := p classes at: (classNames at: index). foundPackage := p]]. foundClass isNil ifTrue:[^self]. self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol). self classListIndex: (self classList indexOf: foundClass name). ! ! !FileDirectory methodsFor: 'file operations' stamp: 'rbb 2/18/2005 13:29'! rename: oldFileName toBe: newFileName | selection oldName newName | "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name." "Modified for retry after GC ar 3/21/98 18:09" oldName _ self fullNameFor: oldFileName. newName _ self fullNameFor: newFileName. (StandardFileStream retryWithGC:[self primRename: oldName asSystemPathName to: newName asSystemPathName] until:[:result| result notNil] forFileNamed: oldName) ~~ nil ifTrue:[^self]. (self fileExists: oldFileName) ifFalse:[ ^self error:'Attempt to rename a non-existent file'. ]. (self fileExists: newFileName) ifTrue:[ selection _ UIManager default chooseFrom: #('delete old version' 'cancel') title: 'Trying to rename a file to be ', newFileName , ' and it already exists.'. selection = 1 ifTrue: [self deleteFileNamed: newFileName. ^ self rename: oldFileName toBe: newFileName]]. ^self error:'Failed to rename file'.! ! !FlapTab methodsFor: 'submorphs-add/remove' stamp: 'rbb 2/18/2005 14:13'! dismissViaHalo "Dismiss the receiver (and its referent), unless it resists" self resistsRemoval ifTrue: [(UIManager default chooseFrom: #( 'Yes' 'Um, no, let me reconsider') title: 'Really throw this flap away?') = 2 ifFalse: [^ self]]. referent delete. self delete! ! !FontSet class methodsFor: 'installing' stamp: 'rbb 2/18/2005 13:20'! installAsDefault "FontSetNewYork installAsDefault" (SelectionMenu confirm: 'Do you want to install ''' , self fontName , ''' as default font?') ifFalse: [^ self]. self installAsTextStyle. "TextConstants at: #OldDefaultTextStyle put: TextStyle default." TextConstants at: #DefaultTextStyle put: (TextStyle named: self fontName). ListParagraph initialize. "rbb 2/18/2005 13:20 - How should this change for UIManger, if at all?" PopUpMenu initialize. StandardSystemView initialize. "SelectionMenu notify: 'The old text style has been saved as ''OldDefaultTextStyle''.'"! ! !FormEditor methodsFor: 'window support' stamp: 'rbb 2/16/2005 16:49'! okToChange ^hasUnsavedChanges contents not ifFalse: [self confirm: 'This drawing was not saved.\Is it OK to close this window?' withCRs ] ifTrue: [true] ! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'rbb 2/18/2005 13:23'! retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock "Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false." | response | [tryBlock value] whileFalse: [ | sema | sema _ Semaphore new. WorldState addDeferredUIMessage: [ response _ UIManager default chooseFrom: #('Retry' 'Give Up') title: troubleString. sema signal. ]. sema wait. response = 2 ifTrue: [abortActionBlock value. ^ false]]. ^ true ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'rbb 2/18/2005 14:25'! copySmartRootsExport: rootArray "Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray." | newRoots list segSize symbolHolder dummy replacements naughtyBlocks goodToGo allClasses sizeHint proj | Smalltalk forgetDoIts. "self halt." symbolHolder _ Symbol allInstances, MultiSymbol allInstances. "Hold onto Symbols with strong pointers, so they will be in outPointers" dummy _ ReferenceStream on: (DummyStream on: nil). "Write to a fake Stream, not a file" "Collect all objects" dummy insideASegment: true. "So Uniclasses will be traced" dummy rootObject: rootArray. "inform him about the root" dummy nextPut: rootArray. (proj _dummy project) ifNotNil: [self dependentsSave: dummy]. allClasses _ SmartRefStream new uniClassInstVarsRefs: dummy. "catalog the extra objects in UniClass inst vars. Put into dummy" allClasses do: [:cls | dummy references at: cls class put: false. "put Player5 class in roots" dummy blockers removeKey: cls class ifAbsent: []]. "refs _ dummy references." arrayOfRoots _ self smartFillRoots: dummy. "guaranteed none repeat" self savePlayerReferences: dummy references. "for shared References table" replacements _ dummy blockers. dummy project "recompute it" ifNil: [self error: 'lost the project!!']. dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project']. dummy _ nil. "force GC?" naughtyBlocks _ arrayOfRoots select: [ :each | (each isKindOf: ContextPart) and: [each hasInstVarRef] ]. "since the caller switched ActiveWorld, put the real one back temporarily" naughtyBlocks isEmpty ifFalse: [ World becomeActiveDuring: [ goodToGo _ UIManager default chooseFrom: #('keep going' 'stop and take a look') title: 'Some block(s) which reference instance variables are included in this segment. These may fail when the segment is loaded if the class has been reshaped. What would you like to do?' . (goodToGo = 1) ifFalse: [ naughtyBlocks inspect. self error: 'Here are the bad blocks']. ]. ]. "Creation of the segment happens here" "try using one-quarter of memory min: four megs to publish (will get bumped later)" sizeHint _ (Smalltalk garbageCollect // 4 // 4) min: 1024*1024. self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true. segSize _ segment size. [(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [ arrayOfRoots _ newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. "with methods pointed at from outside" [(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [ arrayOfRoots _ newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. "with methods, blocks from outPointers" list _ self compactClassesArray. outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). 1 to: outPointers size do: [:ii | (outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil]. (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]. "substitute new object in outPointers" (replacements includesKey: (outPointers at: ii)) ifTrue: [ outPointers at: ii put: (replacements at: (outPointers at: ii))]]. proj ifNotNil: [self dependentsCancel: proj]. symbolHolder.! ! !ImageSegment class methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 13:25'! startUp | choice | "Minimal thing to assure that a .segs folder is present" (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ (FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) ifFalse: [ choice _ UIManager default chooseFrom: #('Create folder' 'Quit without saving') title: 'The folder with segments for this image is missing.\' withCRs, self folder, '\If you have moved or renamed the image file,\' withCRs, 'please Quit and rename the segments folder in the same way'. choice = 1 ifTrue: [FileDirectory default createDirectory: self folder]. choice = 2 ifTrue: [SmalltalkImage current snapshot: false andQuit: true]]] ! ! !Inspector methodsFor: 'menu commands' stamp: 'rbb 2/18/2005 10:58'! inspectElement | sel selSize countString count nameStrs | "Create and schedule an Inspector on an element of the receiver's model's currently selected collection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((sel _ self selection) isKindOf: SequenceableCollection) ifFalse: [(sel isKindOf: MorphExtension) ifTrue: [^ sel inspectElement]. ^ sel inspect]. (selSize _ sel size) == 1 ifTrue: [^ sel first inspect]. selSize <= 20 ifTrue: [nameStrs _ (1 to: selSize) asArray collect: [:ii | ii printString, ' ', (((sel at: ii) printStringLimitedTo: 25) replaceAll: Character cr with: Character space)]. count _ UIManager default chooseFrom: (nameStrs substrings) title: 'which element?'. count = 0 ifTrue: [^ self]. ^ (sel at: count) inspect]. countString _ FillInTheBlank request: 'Which element? (1 to ', selSize printString, ')' initialAnswer: '1'. countString isEmptyOrNil ifTrue: [^ self]. count _ Integer readFrom: (ReadStream on: countString). (count > 0 and: [count <= selSize]) ifTrue: [(sel at: count) inspect] ifFalse: [Beeper beep]! ! !Lexicon methodsFor: 'model glue' stamp: 'rbb 2/16/2005 17:05'! okayToAccept "Answer whether it is okay to accept the receiver's input" | ok aClass reply | (ok _ super okayToAccept) ifTrue: [((aClass _ self selectedClassOrMetaClass) ~~ targetClass) ifTrue: [reply _ UIManager default chooseFrom: {'okay, no problem'. 'cancel - let me reconsider'. 'compile into ', targetClass name, ' instead'. 'compile into a new uniclass'} title: 'Caution!! This would be accepted into class ', aClass name, '. Is that okay?' . reply = 1 ifTrue: [^ true]. reply ~~ 2 ifTrue: [self notYetImplemented]. ^ false]]. ^ ok! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'rbb 2/18/2005 14:27'! defaultAction "Backward compatibility" | response | response _ (UIManager default chooseFrom: #( 'Retry' 'Give Up') title: self messageText). ^ response = 2 ifFalse: [self retry]! ! !ObjectOut methodsFor: 'fetch from disk' stamp: 'rbb 2/18/2005 14:55'! 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 _ (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! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'rbb 2/16/2005 16:49'! presentSpecialMenu "Present a list of expressions, and if the user chooses one, evaluate it in the context of the receiver, a ParagraphEditor. Primarily for debugging, this provides a convenient way to talk to the various views, controllers, and models associated with any text pane" | reply items | self terminateAndInitializeAround: [reply _ (UIManager default chooseFrom: (items _ self specialMenuItems) lines: #()). reply = 0 ifTrue: [^ self]. Compiler new evaluate: (items at: reply) in: [] to: self] ! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'rbb 2/16/2005 16:47'! changeEmphasis: characterStream "Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change. Keeps typeahead." | keyCode attribute oldAttributes index thisSel colors extras indexOfOldAttributes | "control 0..9 -> 0..9" keyCode := ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1. "grab the old set of attributes" indexOfOldAttributes := startBlock stringIndex = stopBlock stringIndex ifTrue:[ "selection is empty, look on character to the left" (startBlock stringIndex - 1) max: 1] ifFalse:[ "selection is not empty, look on leftmost character in the selection" startBlock stringIndex min: stopBlock stringIndex]. oldAttributes := paragraph text attributesAt: indexOfOldAttributes forStyle: paragraph textStyle. thisSel := self selection. "Decipher keyCodes for Command 0-9..." (keyCode between: 1 and: 5) ifTrue: [attribute := TextFontChange fontNumber: keyCode]. keyCode = 6 ifTrue: [colors := #(black magenta red yellow green blue cyan white). extras := ((self class name = #TextMorphEditor) and: [(self morph isKindOf: TextMorphForEditView) not]) "not a system window" ifTrue: [#()] ifFalse: [#('Link to comment of class' 'Link to definition of class' 'Link to hierarchy of class' 'Link to method')]. index := (UIManager default chooseFrom: colors , #('choose color...' 'Do it' 'Print it'), extras, #('be a web URL link' 'Edit hidden info' 'Copy hidden info') lines: (Array with: colors size +1)). index = 0 ifTrue: [^ true]. index <= colors size ifTrue: [attribute := TextColor color: (Color perform: (colors at: index))] ifFalse: [index := index - colors size - 1. "Re-number!!!!!!" index = 0 ifTrue: [attribute := self chooseColor]. index = 1 ifTrue: [attribute := TextDoIt new. thisSel := attribute analyze: self selection asString]. index = 2 ifTrue: [attribute := TextPrintIt new. thisSel := attribute analyze: self selection asString]. (extras size = 0) & (index > 2) ifTrue: [index := index + 4]. "skip those" index = 3 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Comment']. index = 4 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Definition']. index = 5 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Hierarchy']. index = 6 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString]. index = 7 ifTrue: [attribute := TextURL new. thisSel := attribute analyze: self selection asString]. index = 8 ifTrue: ["Edit hidden info" thisSel := self hiddenInfo. "includes selection" attribute := TextEmphasis normal]. index = 9 ifTrue: ["Copy hidden info" self copyHiddenInfo. ^ true]. "no other action" thisSel ifNil: [^ true]]. "Could not figure out what to link to" ]. (keyCode between: 7 and: 11) ifTrue: [sensor leftShiftDown ifTrue: [keyCode = 10 ifTrue: [attribute := TextKern kern: -1]. keyCode = 11 ifTrue: [attribute := TextKern kern: 1]] ifFalse: [attribute := TextEmphasis perform: (#(bold italic narrow underlined struckOut) at: keyCode - 6). oldAttributes do: [:att | ((att dominates: attribute) and: [att ~= TextEmphasis normal]) ifTrue: [attribute turnOff]]]]. (keyCode = 0) ifTrue: [attribute := TextEmphasis normal]. beginTypeInBlock ~~ nil ifTrue: [self insertTypeAhead: characterStream] ifFalse: [self replaceSelectionWith: (thisSel asText addAttribute: attribute)]. emphasisHere := Text addAttribute: attribute toArray: oldAttributes. ^ true! ! !Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 11:01'! correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." | alternatives aStream choice correctSelector userSelection lines firstLine | "If we can't ask the user, assume that the keyword will be defined later" self interactive ifFalse: [ ^ proposedKeyword asSymbol ]. userSelection _ requestor selectionInterval. requestor selectFrom: spots first first to: spots last last. requestor select. alternatives _ Symbol possibleSelectorsFor: proposedKeyword. self flag: #toBeFixed. "alternatives addAll: (MultiSymbol possibleSelectorsFor: proposedKeyword)." aStream _ WriteStream on: (String new: 200). aStream nextPutAll: (proposedKeyword contractTo: 35); cr. firstLine _ 1. alternatives do: [:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr]. aStream nextPutAll: 'cancel'. lines _ Array with: firstLine with: (alternatives size + firstLine). choice _ (UIManager default chooseFrom: (aStream contents substrings) lines: lines title: 'Unknown selector, please\confirm, correct, or cancel' withCRs). (choice = 0) | (choice > (lines at: 2)) ifTrue: [ ^ abortAction value ]. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ]. correctSelector _ alternatives at: choice - 1. self substituteSelector: correctSelector keywords wordIntervals: spots. ((proposedKeyword last ~= $:) and: [correctSelector last == $:]) ifTrue: [ ^ abortAction value]. ^ correctSelector. ! ! !Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 09:01'! correctVariable: proposedVariable interval: spot "Correct the proposedVariable to a known variable, or declare it as a new variable if such action is requested. We support declaring lowercase variables as temps or inst-vars, and uppercase variables as Globals or ClassVars, depending on whether the context is nil (class=UndefinedObject). Spot is the interval within the test stream of the variable. rr 3/4/2004 10:26 : adds the option to define a new class. " | tempIvar labels actions lines alternatives binding userSelection choice action | "Check if this is an i-var, that has been corrected already (ugly)" (encoder classEncoding allInstVarNames includes: proposedVariable) ifTrue: [ ^LiteralVariableNode new name: proposedVariable index: (encoder classEncoding allInstVarNames indexOf: proposedVariable) - 1 type: 1; yourself ]. "If we can't ask the user for correction, make it undeclared" self interactive ifFalse: [ ^encoder undeclared: proposedVariable ]. "First check to see if the requestor knows anything about the variable" tempIvar _ proposedVariable first canBeNonGlobalVarInitial. (tempIvar and: [ (binding _ requestor bindingOf: proposedVariable) notNil ]) ifTrue: [ ^encoder global: binding name: proposedVariable ]. userSelection _ requestor selectionInterval. requestor selectFrom: spot first to: spot last. requestor select. "Build the menu with alternatives" labels _ OrderedCollection new. actions _ OrderedCollection new. lines _ OrderedCollection new. alternatives _ encoder possibleVariablesFor: proposedVariable. tempIvar ifTrue: [ labels add: 'declare temp'. actions add: [ self declareTempAndPaste: proposedVariable ]. labels add: 'declare instance'. actions add: [ self declareInstVar: proposedVariable ] ] ifFalse: [ labels add: 'define new class'. actions add: [self defineClass: proposedVariable]. labels add: 'declare global'. actions add: [ self declareGlobal: proposedVariable ]. encoder classEncoding == UndefinedObject ifFalse: [ labels add: 'declare class variable'. actions add: [ self declareClassVar: proposedVariable ] ] ]. lines add: labels size. alternatives do: [ :each | labels add: each. actions add: [ self substituteWord: each wordInterval: spot offset: 0. encoder encodeVariable: each ] fixTemps ]. lines add: labels size. labels add: 'cancel'. "Display the pop-up menu" choice _ (UIManager default chooseFrom: labels asArray lines: lines asArray title: 'Unknown variable: ', proposedVariable, ' please correct, or cancel:'). action _ actions at: choice ifAbsent: [ ^self fail ]. "Execute the selected action" requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. ^action value! ! !Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 09:10'! queryUndefined | varStart varName | varName _ parseNode key. varStart _ self endOfLastToken + requestorOffset - varName size + 1. requestor selectFrom: varStart to: varStart + varName size - 1; select. ((UIManager default chooseFrom: #('yes' 'no') title: ((varName , ' appears to be\undefined at this point.Proceed anyway?') withCRs asText makeBoldFrom: 1 to: varName size)) = 1) ifFalse: [^ self fail]! ! !Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 09:08'! removeUnusedTemps "Scan for unused temp names, and prompt the user about the prospect of removing each one found" | str end start madeChanges | madeChanges _ false. str _ requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | ((UIManager default chooseFrom: #('yes' 'no') title: ((temp , ' appears to be\unused in this method.\OK to remove it?') withCRs asText makeBoldFrom: 1 to: temp size)) = 1) ifTrue: [(encoder encodeVariable: temp) isUndefTemp ifTrue: [end _ tempsMark. ["Beginning at right temp marker..." start _ end - temp size + 1. end < temp size or: [temp = (str copyFrom: start to: end) and: [(str at: start-1) isAlphaNumeric not & (str at: end+1) isAlphaNumeric not]]] whileFalse: ["Search left for the unused temp" end _ requestor nextTokenFrom: end direction: -1]. end < temp size ifFalse: [(str at: start-1) = $ ifTrue: [start _ start-1]. requestor correctFrom: start to: end with: ''. str _ str copyReplaceFrom: start to: end with: ''. madeChanges _ true. tempsMark _ tempsMark - (end-start+1)]] ifFalse: [self inform: 'You''ll first have to remove the statement where it''s stored into']]]. madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! ! !Player methodsFor: 'misc' stamp: 'rbb 2/16/2005 17:12'! beNotZero: aNumber "This is a runtime check if the arg to divide in a script is zero. If it is, put up a message from M. Mouse. Return 0.001 instead of 0. Note the time. If fails again within 1 min., don't tell the user again." aNumber = 0 ifFalse: [^ aNumber]. "normal case" "We have a problem" TimeOfError ifNil: [TimeOfError _ Time totalSeconds] ifNotNil: [(Time totalSeconds - TimeOfError) > 45 ifTrue: [ TimeOfError _ Time totalSeconds. "in case user interrupt and reenter" self inform: 'Dividing by zero makes a number too large for even a Sorcerer to handle. Please change your script. -- M. Mouse'. TimeOfError _ Time totalSeconds]]. ^ 0.001! ! !PluggableFileList class methodsFor: 'validateBlocks' stamp: 'rbb 2/18/2005 11:35'! okToOpen: aFileNameString without: aSuffixString "Answer whether user confirms that it is ok to overwrite the file named in aString" ^ 1 = (UIManager default chooseFrom: #('overwrite that file' 'select another file') title: aFileNameString, ' already exists.'). ! ! !PluggableFileList class methodsFor: 'validateBlocks' stamp: 'rbb 2/18/2005 11:36'! okToOverwrite: aString "Answer whether user confirms that it is ok to overwrite the file named in aString" ^ 1 = (UIManager default chooseFrom: #('overwrite that file' 'select another file') title: aString, ' already exists.') ! ! !Preferences class methodsFor: 'fonts' stamp: 'rbb 2/18/2005 12:55'! setMenuFontTo: aFont "rbb 2/18/2005 12:54 - How should this be changed to work with the UIManager, if at all?" Parameters at: #standardMenuFont put: aFont. PopUpMenu setMenuFontTo: aFont! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'rbb 2/18/2005 08:59'! changePriority | str newPriority nameAndRules | nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules third ifFalse: [self inform: 'Nope, won''t change priority of ' , nameAndRules first. ^ self]. str _ FillInTheBlank request: 'New priority' initialAnswer: selectedProcess priority asString. newPriority _ str asNumber asInteger. newPriority ifNil: [^ self]. (newPriority < 1 or: [newPriority > Processor highestPriority]) ifTrue: [self inform: 'Bad priority'. ^ self]. self class setProcess: selectedProcess toPriority: newPriority. self updateProcessList! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'rbb 2/18/2005 08:59'! debugProcess | nameAndRules | nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules third ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first. ^ self]. self class debugProcess: selectedProcess.! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'rbb 2/18/2005 09:00'! suspendProcess | nameAndRules | selectedProcess isSuspended ifTrue: [^ self]. nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules second ifFalse: [self inform: 'Nope, won''t suspend ' , nameAndRules first. ^ self]. self class suspendProcess: selectedProcess. self updateProcessList! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'rbb 2/18/2005 09:00'! terminateProcess | nameAndRules | nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules second ifFalse: [self inform: 'Nope, won''t kill ' , nameAndRules first. ^ self]. self class terminateProcess: selectedProcess. self updateProcessList! ! !Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:57'! decideAboutCreatingBlank: otherProjectName | resp | "20 Oct - just do it" true "version isNil" ifFalse: [ "if saved, then maybe don't create" resp _ (UIManager default chooseFrom: #('Yes, make it up' 'No, skip it') title: ('I cannot locate the project\', otherProjectName, '\Would you like me to create a new project\with that name?' ) withCRs). resp = 1 ifFalse: [^ nil] ]. ^Project openBlankProjectNamed: otherProjectName! ! !Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:58'! exportSegmentWithCatagories: catList classes: classList fileName: aFileName directory: aDirectory "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 .extSeg. What do 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 | self halt. "unused" "world == World ifTrue: [^ false]." "self inform: 'Can''t send the current world out'." world isMorph ifFalse: [ self projectParameters at: #isMVC put: true. ^ false]. "Only Morphic projects for now" world ifNil: [^ false]. world presenter ifNil: [^ false]. Utilities emptyScrapsBook. world currentHand pasteBuffer: nil. "don't write the paste buffer." world currentHand mouseOverHandler initialize. "forget about any references here" "Display checkCurrentHandForObjectToPaste." Command initialize. world clearCommandHistory. world fullReleaseCachedState; releaseViewers. world cleanseStepList. world localFlapTabs size = world flapTabs size ifFalse: [ self error: 'Still holding onto Global flaps']. world releaseSqueakPages. ScriptEditorMorph 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 projectParameters at: #revertToMe ifAbsent: [nil]. self projectParameters removeKey: #revertToMe ifAbsent: []. roots _ OrderedCollection new. roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail. roots add: world activeHand; addAll: classList; addAll: (classList collect: [:cls | cls class]). roots _ roots reject: [ :x | x isNil]. "early saves may not have active hand or thumbnail" catList do: [:sysCat | (SystemOrganization listAtCategoryNamed: sysCat asSymbol) do: [:symb | roots add: (Smalltalk at: symb); add: (Smalltalk at: symb) class]]. is _ ImageSegment new copySmartRootsExport: roots asArray. "old way was (is _ ImageSegment new copyFromRootsForExport: roots asArray)" is state = #tooBig ifTrue: [^ 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.' withCRs]. str isEmpty ifFalse: [ ans _ (UIManager default chooseFrom: #('Do not write file' 'Write file anyway' 'Debug') title: str). ans = 1 ifTrue: [ revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. ^ false]. ans = 3 ifTrue: [self halt: 'Segment not written']]. is writeForExportWithSources: aFileName inDirectory: aDirectory. revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. holder. world flapTabs do: [:ft | (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. is arrayOfRoots do: [:obj | obj class == ScriptEditorMorph ifTrue: [obj unhibernate]]. ^ true ! ! !Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:53'! exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory "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 .extSeg. What do 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 | "An experimental version to fileout a changeSet first so that a project can contain its own classes" world isMorph ifFalse: [ self projectParameters at: #isMVC put: true. ^ false]. "Only Morphic projects for now" world ifNil: [^ false]. world presenter ifNil: [^ false]. Utilities emptyScrapsBook. world currentHand pasteBuffer: nil. "don't write the paste buffer." world currentHand mouseOverHandler initialize. "forget about any references here" "Display checkCurrentHandForObjectToPaste." Command initialize. world clearCommandHistory. world fullReleaseCachedState; releaseViewers. world cleanseStepList. world localFlapTabs size = world flapTabs size ifFalse: [ self error: 'Still holding onto Global flaps']. world releaseSqueakPages. ScriptEditorMorph 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 projectParameters at: #revertToMe ifAbsent: [nil]. self projectParameters removeKey: #revertToMe ifAbsent: []. roots _ OrderedCollection new. roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail. roots add: world activeHand. "; 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...)'. "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 new 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. ^ 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.' withCRs]. str isEmpty ifFalse: [ ans _ (UIManager default chooseFrom: #('Do not write file' 'Write file anyway' 'Debug') title: str). ans = 1 ifTrue: [ revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. collector replaceAll. ^ false]. ans = 3 ifTrue: [ collector replaceAll. self halt: 'Segment not written']]. 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 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" "Now update everything that we know about" mgr updateResourcesFrom: collector. 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 class == ScriptEditorMorph ifTrue: [obj unhibernate]]. ^ true ! ! !Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:51'! 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 ]. 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 _ (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' 'Cancel') title: 'A newer version exists on the server.'). 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 installRemoteNamed: pair first from: server named: self name in: parentProject ] ! ! !Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:56'! storeOnServerInnards "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." | resp newName primaryServerDirectory serverVersionPair localDirectory localVersionPair myVersionNumber warning maxNumber suppliedPassword oldResourceUrl | self assureIntegerVersion. "Find out what version" primaryServerDirectory _ self primaryServerIfNil: [ (primaryServerDirectory _ self findAFolderToStoreProjectIn) ifNil: [^self]. oldResourceUrl _ self resourceUrl. primaryServerDirectory == #localOnly ifTrue: [ self storeNewPrimaryURL: FileDirectory default url. nil ] ifFalse: [ self storeNewPrimaryURL: primaryServerDirectory downloadUrl. primaryServerDirectory ]. ]. localDirectory _ self squeakletDirectory. serverVersionPair _ self class mostRecent: self name onServer: primaryServerDirectory. localVersionPair _ self class mostRecent: self name onServer: localDirectory. maxNumber _ myVersionNumber _ self currentVersionNumber. ProgressNotification signal: '2:versionsDetected'. warning _ ''. myVersionNumber < serverVersionPair second ifTrue: [ warning _ warning,'\There are newer version(s) on the server' translated. maxNumber _ maxNumber max: serverVersionPair second. ]. myVersionNumber < localVersionPair second ifTrue: [ warning _ warning,'\There are newer version(s) in the local directory' translated. maxNumber _ maxNumber max: localVersionPair second. ]. "8 Nov 2000 - only check on the first attempt to publish" myVersionNumber = 0 ifTrue: [ warning isEmpty ifFalse: [ myVersionNumber = 0 ifTrue: [ warning _ warning,'\THIS PROJECT HAS NEVER BEEN SAVED' translated. ]. warning _ 'WARNING' translated, '\Project: ' translated, self name,warning. resp _ (UIManager default chooseFrom: (Array with: 'Store anyway' translated with: 'Cancel' translated) title: (warning, '\Please cancel, rename this project, and see what is there.' translated) withCRs). resp ~= 1 ifTrue: [^ nil] ]. ]. version _ self bumpVersion: maxNumber. oldResourceUrl ifNotNil: [self resourceManager adjustToNewServer: self resourceUrl from: oldResourceUrl]. "write locally - now zipped automatically" newName _ self versionedFileName. lastSavedAtSeconds _ Time totalSeconds. self exportSegmentFileName: newName directory: localDirectory. (localDirectory readOnlyFileNamed: newName) setFileTypeToObject; close. ProgressNotification signal: '4:localSaveComplete'. "3 is deep in export logic" primaryServerDirectory ifNotNil: [ suppliedPassword _ ''. Preferences passwordsOnPublish ifTrue: [ suppliedPassword _ FillInTheBlank requestPassword: 'Project password' translated ]. [ primaryServerDirectory writeProject: self inFileNamed: newName asFileName fromDirectory: localDirectory. ] on: ProjectPasswordNotification do: [ :ex | ex resume: (suppliedPassword ifNil: ['']) ]. ]. ProgressNotification signal: '9999 save complete'. "Later, store with same name on secondary servers. Still can be race conditions. All machines will go through the server list in the same order." "2 to: servers size do: [:aServer | aServer putFile: local named: newName]." ! ! !Project methodsFor: 'file in/out' stamp: 'rbb 2/16/2005 17:15'! tryToFindAServerWithMe | resp primaryServerDirectory | urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList copy]. [self primaryServer isNil] whileTrue: [ resp _ (UIManager default chooseFrom: #('Try to find a server' 'Cancel') title: 'This project thinks it has never been on a server'). resp ~= 1 ifTrue: [^ nil]. (primaryServerDirectory _ self findAFolderToLoadProjectFrom) ifNil: [^nil]. self storeNewPrimaryURL: primaryServerDirectory downloadUrl. ]. ^self primaryServer ! ! !ProjectController methodsFor: 'control activity' stamp: 'rbb 2/16/2005 16:24'! redButtonActivity | index | view isCollapsed ifTrue: [^ super redButtonActivity]. (view insetDisplayBox containsPoint: Sensor cursorPoint) ifFalse: [^ super redButtonActivity]. index _ (UIManager default chooseFrom: #('enter' 'jump to project...') lines: #()). index = 0 ifTrue: [^ self]. "save size on enter for thumbnail on exit" model setViewSize: view insetDisplayBox extent. index = 1 ifTrue: [^ model enter: false revert: false saveForRevert: false]. index = 2 ifTrue: [Project jumpToProject. ^ self]. ! ! !SecurityManager methodsFor: 'security operations' stamp: 'rbb 2/18/2005 14:27'! enterRestrictedMode "Some insecure contents was encountered. Close all doors and proceed." self isInRestrictedMode ifTrue:[^true]. Preferences securityChecksEnabled ifFalse:[^true]. "it's been your choice..." Preferences warnAboutInsecureContent ifTrue:[ ( UIManager default chooseFrom: #('Load it anyways' 'Do not load it') title: 'You are about to load some insecure content. If you continue, access to files as well as some other capabilities will be limited.') = 1 ifFalse:[ "user doesn't really want it" ^false. ]. ]. "here goes the actual restriction" self flushSecurityKeys. self disableFileAccess. self disableImageWrite. "self disableSocketAccess." FileDirectory setDefaultDirectory: self untrustedUserDirectory. ^true ! ! !ServerDirectory methodsFor: 'dis/connect' stamp: 'rbb 2/18/2005 14:41'! openFTPClient | loginSuccessful what | client ifNotNil: [client isConnected ifTrue: [^client] ifFalse: [client := nil]]. client _ FTPClient openOnHostNamed: server. loginSuccessful := false. [loginSuccessful] whileFalse: [ [loginSuccessful := true. client loginUser: self user password: self password] on: LoginFailedException do: [:ex | passwordHolder _ nil. what _ UIManager default chooseFrom: #('enter password' 'give up') title: 'Would you like to try another password?'. what = 1 ifFalse: [self error: 'Login failed.'. ^nil]. loginSuccessful := false]]. client changeDirectoryTo: directory. ^client! ! !ServerDirectory methodsFor: 'file directory' stamp: 'rbb 2/18/2005 14:38'! newFileNamed: fullName "Create a RemoteFileStream. If the file exists, and complain. fullName is directory path, and does include name of the server. Or it can just be a fileName. Only write the data upon close." | file remoteStrm selection | file _ self asServerFileNamed: fullName. file readWrite. file isTypeFile ifTrue: [ ^ FileStream newFileNamed: (file fileNameRelativeTo: self)]. file exists ifTrue: [ selection _ UIManager default chooseFrom: #('overwrite that file' 'choose another name' 'cancel') title: (file fullNameFor: file fileName) , ' already exists.'] ifFalse: [selection _ 1]. selection = 1 ifTrue: [remoteStrm _ RemoteFileStream on: (String new: 2000). remoteStrm remoteFile: file. remoteStrm dataIsValid. "empty stream is the real contents!!" ^ remoteStrm]. "no actual writing till close" selection = 2 ifTrue: [ ^ self newFileNamed: (FillInTheBlank request: 'Enter a new file name' initialAnswer: file fileName)]. ^ nil "cancel"! ! !ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:40'! checkServersWithPrefix: prefix andParseListInto: listBlock "Check that all servers are up and have the latest Updates.list. Warn user when can't write to a server that can still be read. The contents of updates.list is parsed into {{vers. {fileNames*}}*}, and returned via the listBlock." | serverList updateLists listContents maxSize outOfDateServers | serverList _ self serversInGroup. serverList isEmpty ifTrue: [^Array new]. updateLists := Dictionary new. serverList do: [:updateServer | [listContents := updateServer getFileNamed: prefix , 'updates.list'. updateLists at: updateServer put: listContents] on: Error do: [:ex | UIManager default chooseFrom: #('Cancel entire update') title: 'Server ', updateServer moniker, ' is unavailable.\Please consider phoning the administator.\' withCRs, listContents. ^Array new]]. maxSize := (updateLists collect: [:each | each size]) max. outOfDateServers := updateLists keys select: [:updateServer | (updateLists at: updateServer) size < maxSize]. outOfDateServers do: [:updateServer | (self outOfDate: updateServer) ifTrue: [^Array new]]. listBlock value: (Utilities parseListContents: listContents). serverList removeAll: outOfDateServers. ^serverList ! ! !ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:33'! copyUpdatesNumbered: selectList toVersion: otherVersion "Into the section of updates.list corresponding to otherVersion, copy all the fileNames from this version matching the selectList." " (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') copyUpdatesNumbered: #(4411 4412) to version: 'Squeak3.1beta'. " | myServers updateStrm seq indexPrefix listContents version versIndex lastNum otherVersIndex additions outOfOrder | self openGroup. indexPrefix _ (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers _ self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents _ x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version _ SystemVersion current version. versIndex _ (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" otherVersIndex _ (listContents collect: [:pair | pair first]) indexOf: otherVersion. otherVersIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for the target version'. self closeGroup. ^ nil]. "abort" versIndex < listContents size ifTrue: [(self confirm: 'This system, ', version , ' is not the latest version.\OK to copy updates from that old version?' withCRs) ifFalse: [self closeGroup. ^ nil]]. "abort" "Append all fileNames in my list that are not in the export list" additions _ OrderedCollection new. outOfOrder _ OrderedCollection new. lastNum _ (listContents at: otherVersIndex) last isEmpty ifTrue: [0] "no checking if the current list is empty" ifFalse: [(listContents at: otherVersIndex) last last initialIntegerOrNil]. (listContents at: versIndex) last do: [:fileName | seq _ fileName initialIntegerOrNil. (selectList includes: seq) ifTrue: [seq > lastNum ifTrue: [additions addLast: fileName] ifFalse: [outOfOrder addLast: seq]]]. outOfOrder isEmpty ifFalse: [UIManager default inform: 'Updates numbered ' , outOfOrder asArray printString, ' are out of order.\ The last update in ' withCRs, otherVersion, ' is ', lastNum printString, '.\No update will take place.' withCRs. self closeGroup. ^ nil]. "abort" "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "Write a new copy of updates.list on all servers..." listContents at: otherVersIndex put: {otherVersion. (listContents at: otherVersIndex) last , additions}. updateStrm _ ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. ! ! !ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:31'! exportUpdatesExcept: skipList "Into the section of updates.list corresponding to this version, copy all the fileNames in the named updates.list for this group that are more recently numbered." " (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') exportUpdatesExcept: #(3959). " | myServers updateStrm response seq indexPrefix listContents version versIndex lastNum expContents expVersIndex additions | self openGroup. indexPrefix _ (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers _ self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents _ x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version _ SystemVersion current version. versIndex _ (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" versIndex < listContents size ifTrue: [response _ UIManager default chooseFrom: #('Make update from an older version' 'Cancel update') title: 'This system, ', SystemVersion current version, ' is not the latest version'. response = 1 ifFalse: [self closeGroup. ^ nil]]. "abort" "Get the old export updates.list." expContents _ Utilities parseListContents: (myServers first getFileNamed: 'updates.list'). expVersIndex _ (expContents collect: [:pair | pair first]) indexOf: version. expVersIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" lastNum _ (expContents at: expVersIndex) last isEmpty ifTrue: [0] "no checking if the current list is empty" ifFalse: [(expContents at: expVersIndex) last last initialIntegerOrNil]. "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: 'updates.list.bk'. Utilities writeList: expContents toStream: (FileStream fileNamed: 'updates.list.bk'). "Append all fileNames in my list that are not in the export list" additions _ OrderedCollection new. (listContents at: versIndex) last do: [:fileName | seq _ fileName initialIntegerOrNil. (seq > lastNum and: [(skipList includes: seq) not]) ifTrue: [additions addLast: fileName]]. expContents at: expVersIndex put: {version. (expContents at: expVersIndex) last , additions}. (self confirm: 'Do you really want to export ' , additions size printString , ' recent updates?') ifFalse: [self closeGroup. ^ nil]. "abort" "Write a new copy of updates.list on all servers..." updateStrm _ ReadStream on: (String streamContents: [:s | Utilities writeList: expContents toStream: s]). myServers do: [:aServer | updateStrm reset. aServer putFile: updateStrm named: 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. ! ! !ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:39'! outOfDate: aServer "Inform the user that this server does not have a current version of 'Updates.list' Return true if the user does not want any updates to happen." | response | response _ UIManager default chooseFrom: #('Install on others' 'Cancel entire update') title: 'The server ', aServer moniker, ' is not up to date. Please store the missing updates maually.'. ^ response ~= 1! ! !ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:42'! putUpdate: fileStrm "Put this file out as an Update on the servers of my group. Each version of the system may have its own set of update files, or they may all share the same files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class readServerUpdatesThrough:saveLocally:updateImage:. When two sets of updates are stored on the same directory, one of them has a * in its serverUrls description. When that is true, the first word of the description is put on the front of 'updates.list', and that index file is used." | myServers updateStrm newName response localName seq indexPrefix listContents version versIndex lastNum stripped | localName _ fileStrm localName. fileStrm size = 0 ifTrue: [^ self inform: 'That file has zero bytes!! May have a new name.']. (fileStrm contentsOfEntireFile includes: Character linefeed) ifTrue: [self notifyWithLabel: 'That file contains linefeeds. Proceed if... you know that this is okay (e.g. the file contains raw binary data).']. fileStrm reset. (self checkNames: {localName}) ifFalse: [^ nil]. "illegal characters" response _ UIManager default chooseFrom: #('Install update' 'Cancel update') title: 'Do you really want to broadcast the file ', localName, '\to every Squeak user who updates from ' withCRs, self groupName, '?'. response = 1 ifFalse: [^ nil]. "abort" self openGroup. indexPrefix _ (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers _ self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents _ x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version _ SystemVersion current version. versIndex _ (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" "A few affirmations..." versIndex < listContents size ifTrue: [(self confirm: 'This system, ', version , ' is not the latest version.\Make update for an older version?' withCRs) ifFalse: [self closeGroup. ^ nil]]. "abort" (listContents at: versIndex) last isEmpty ifTrue: [(self confirm: 'Please confirm that you mean to issue the first update for ' , version , '\(otherwise something is wrong).' withCRs) ifFalse: [self closeGroup. ^ nil]]. "We now determine next update number to be max of entire index" lastNum _ listContents inject: 0 into: [:max :pair | pair last isEmpty ifTrue: [max] ifFalse: [max max: pair last last initialIntegerOrNil]]. "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "append name to updates with new sequence number" seq _ (lastNum + 1) printString padded: #left to: 4 with: $0. "strip off any old seq number" stripped _ localName copyFrom: (localName findFirst: [:c | c isDigit not]) to: localName size. newName _ seq , stripped. listContents at: versIndex put: {version. (listContents at: versIndex) last copyWith: newName}. "Write a new copy on all servers..." updateStrm _ ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | fileStrm reset. "reopen" aServer putFile: fileStrm named: newName retry: true. updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. "rename the file locally (may fail)" fileStrm directory rename: localName toBe: newName. ! ! !ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:37'! putUpdateMulti: list fromDirectory: updateDirectory "Put these files out as an Update on the servers of my group. List is an array of local file names with or without number prefixes. Each version of the system has its own set of update files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class absorbUpdatesFromServer." | myServers updateStrm lastNum response newNames file numStr indexPrefix listContents version versIndex seq stripped | (self checkNames: (list collect: "Check the names without their numbers" [:each | each copyFrom: (each findFirst: [:c | c isDigit not]) to: each size])) ifFalse: [^ nil]. response _ UIManager default chooseFrom: #('Install update' 'Cancel update') title: 'Do you really want to broadcast ', list size printString, ' updates', '\to every Squeak user who updates from ' withCRs, self groupName, '?'. response = 1 ifFalse: [^ nil]. "abort" self openGroup. indexPrefix _ (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers _ self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents _ x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version _ SystemVersion current version. versIndex _ (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" lastNum _ (listContents at: versIndex) last last initialIntegerOrNil. versIndex < listContents size ifTrue: [response _ UIManager default chooseFrom: #('Make update for an older version' 'Cancel update') title: 'This system, ', SystemVersion current version, ' is not the latest version'. response = 1 ifFalse: [self closeGroup. ^ nil]. numStr _ FillInTheBlank request: 'Please confirm or change the starting update number' initialAnswer: (lastNum+1) printString. lastNum _ numStr asNumber - 1]. "abort" "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "Append names to updates with new sequence numbers" newNames _ list with: (lastNum+1 to: lastNum+list size) collect: [:each :num | seq _ num printString padded: #left to: 4 with: $0. "strip off any old seq number" stripped _ each copyFrom: (each findFirst: [:c | c isDigit not]) to: each size. seq , stripped]. listContents at: versIndex put: {version. (listContents at: versIndex) second , newNames}. "Write a new copy on all servers..." updateStrm _ ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | list doWithIndex: [:local :ind | file _ updateDirectory oldFileNamed: local. aServer putFile: file named: (newNames at: ind) retry: true. file close]. updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. "rename the file locally" list with: newNames do: [:local :newName | updateDirectory rename: local toBe: newName]. ! ! !SmartRefStream methodsFor: 'class changed shape' stamp: 'rbb 2/18/2005 11:24'! writeClassRenameMethod: sel was: oldName fromInstVars: oldList "The class coming is unknown. Ask the user for the existing class it maps to. If got one, write a method, and restart the obj fileIn. If none, write a dummy method and get the user to complete it later. " | tell choice newName answ code | self flag: #bobconv. tell _ 'Reading an instance of ', oldName, '. Which modern class should it translate to?'. answ _ (UIManager default chooseFrom: #('Let me type the name now' 'Let me think about it' 'Let me find a conversion file on the disk') title: tell). answ = 1 ifTrue: [ tell := 'Name of the modern class {1} should translate to:' translated format: {oldName}. choice _ FillInTheBlank request: tell. "class name" (choice size = 0) ifTrue: [answ _ 'conversion method needed'] ifFalse: [newName _ choice. answ _ Smalltalk at: newName asSymbol ifAbsent: ['conversion method needed']. answ class == String ifFalse: [renamed at: oldName asSymbol put: answ name]]]. (answ = 3) | (answ = 0) ifTrue: [self close. ^ 'conversion method needed']. answ = 2 ifTrue: [answ _ 'conversion method needed']. answ = 'conversion method needed' ifTrue: [ self close. newName _ 'PutNewClassHere']. code _ WriteStream on: (String new: 500). code nextPutAll: sel; cr. code cr; tab; nextPutAll: '^ ', newName. "Return new class" self class compile: code contents classified: 'conversion'. newName = 'PutNewClassHere' ifTrue: [ self inform: 'Please complete the following method and then read-in the object file again.'. SystemNavigation default browseAllImplementorsOf: sel asSymbol]. "The class version number only needs to change under one specific circumstance. That is when the first letters of the instance variables have stayed the same, but their meaning has changed. A conversion method is needed, but this system does not know it. If this is true for class Foo, define classVersion in Foo class. Beware of previous object fileouts already written after the change in meaning, but before bumping the version number. They have the old (wrong) version number, say 2. If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3." ^ answ! ! !StandardFileMenu methodsFor: 'basic control sequences' stamp: 'rbb 2/16/2005 16:59'! confirmExistingFiles: aResult |choice| (aResult directory fileExists: aResult name) ifFalse: [^aResult]. choice _ (UIManager default chooseFrom: #('overwrite that file' 'choose another name' 'cancel') title: aResult name, ' already exists.'). choice = 1 ifTrue: [ aResult directory deleteFileNamed: aResult name ifAbsent: [^self startUpWithCaption: 'Can''t delete ', aResult name, ' Select another file']. ^aResult]. choice = 2 ifTrue: [^self startUpWithCaption: 'Select Another File']. ^nil ! ! !StandardFileStream class methodsFor: 'error handling' stamp: 'rbb 2/18/2005 12:44'! fileDoesNotExistUserHandling: fullFileName | selection newName | selection _ (UIManager default chooseFrom: #('create a new file' 'choose another name' 'cancel') title: (FileDirectory localNameFor: fullFileName) , '\does not exist.' withCRs). selection = 1 ifTrue: [^ self new open: fullFileName forWrite: true]. selection = 2 ifTrue: [ newName _ FillInTheBlank request: 'Enter a new file name' initialAnswer: fullFileName. ^ self oldFileNamed: (self fullName: newName)]. self halt! ! !StandardFileStream class methodsFor: 'error handling' stamp: 'rbb 2/18/2005 12:45'! fileExistsUserHandling: fullFileName | dir localName choice newName newFullFileName | dir _ FileDirectory forFileName: fullFileName. localName _ FileDirectory localNameFor: fullFileName. choice _ (UIManager default chooseFrom: #('overwrite that file' 'choose another name' 'cancel') title: localName, ' already exists.'). choice = 1 ifTrue: [ dir deleteFileNamed: localName ifAbsent: [self error: 'Could not delete the old version of that file']. ^ self new open: fullFileName forWrite: true]. choice = 2 ifTrue: [ newName _ FillInTheBlank request: 'Enter a new file name' initialAnswer: fullFileName. newFullFileName _ self fullName: newName. ^ self newFileNamed: newFullFileName]. self error: 'Please close this to abort file opening'! ! !StandardFileStream class methodsFor: 'error handling' stamp: 'rbb 2/18/2005 12:38'! readOnlyFileDoesNotExistUserHandling: fullFileName | dir files choices selection newName fileName | dir _ FileDirectory forFileName: fullFileName. files _ dir fileNames. fileName _ FileDirectory localNameFor: fullFileName. choices _ fileName correctAgainst: files. choices add: 'Choose another name'. choices add: 'Cancel'. selection _ (UIManager default chooseFrom: choices lines: (Array with: 5) title: (FileDirectory localNameFor: fullFileName), 'does not exist.'). selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"]. selection < (choices size - 1) ifTrue: [ newName _ (dir pathName , FileDirectory slash , (choices at: selection))]. selection = (choices size - 1) ifTrue: [ newName _ FillInTheBlank request: 'Enter a new file name' initialAnswer: fileName]. newName = '' ifFalse: [^ self readOnlyFileNamed: (self fullName: newName)]. ^ self error: 'Could not open a file'! ! !StrikeFont class methodsFor: 'font creation' stamp: 'rbb 2/18/2005 13:21'! hostFontFromUser "StrikeFont hostFontFromUser" | fontNames index labels | fontNames _ self listFontNames asSortedCollection. labels _ WriteStream on: (String new: 100). fontNames do:[:fn| labels nextPutAll: fn] separatedBy:[labels cr]. index _ (UIManager default chooseFrom: (labels contents substrings) title: 'Choose your font'). index = 0 ifTrue:[^nil]. ^fontNames at: index! ! !HostFont class methodsFor: 'accessing' stamp: 'rbb 2/18/2005 13:23'! fontNameFromUser "HostFont fontNameFromUser" | fontNames index labels | fontNames _ self listFontNames asSortedCollection. labels _ WriteStream on: (String new: 100). fontNames do:[:fn| labels nextPutAll: fn] separatedBy:[labels cr]. index _ (UIManager default chooseFrom: (labels contents substrings) title: 'Choose your font'). index = 0 ifTrue:[^nil]. ^fontNames at: index! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'rbb 2/18/2005 09:21'! majorShrink "Undertake a major shrinkage of the image. This method throws out lots of the system that is not needed for, eg, operation in a hand-held PC. majorShrink produces a 999k image in Squeak 2.8 Smalltalk majorShrink; abandonSources; lastRemoval" | oldDicts newDicts | self isMorphic ifTrue: [^ self error: 'You can only run majorShrink in MVC']. Project current isTopProject ifFalse: [^ self error: 'You can only run majorShrink in the top project']. (self confirm: 'All sub-projects will be deleted from this image. You should already have made a backup copy, or you must save with a different name after shrinking. Shall we proceed to discard most of the content in this image?') ifFalse: [^ self inform: 'No changes have been made.']. "Remove all projects but the current one. - saves 522k" ProjectView allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate]. Project current setParent: Project current. MorphWorldView allInstancesDo: [:pv | pv topView controller closeAndUnscheduleNoTerminate]. self at: #Wonderland ifPresent: [:cls | cls removeActorPrototypesFromSystem]. Player freeUnreferencedSubclasses. MorphicModel removeUninstantiatedModels. Utilities classPool at: #ScrapsBook put: nil. Utilities zapUpdateDownloader. ProjectHistory currentHistory initialize. Project rebuildAllProjects. "Smalltalk discardVMConstruction." "755k" self discardSoundSynthesis. "544k" self discardOddsAndEnds. "227k" self discardNetworking. "234k" "Smalltalk discard3D." "407k" self discardFFI. "33k" self discardMorphic. "1372k" Symbol rehash. "40k" "Above by itself saves about 4,238k" "Remove references to a few classes to be deleted, so that they won't leave obsolete versions around." ChangeSet class compile: 'defaultName ^ ''Changes'' ' classified: 'initialization'. ScreenController removeSelector: #openChangeManager. ScreenController removeSelector: #exitProject. ScreenController removeSelector: #openProject. ScreenController removeSelector: #viewImageImports. "Now delete various other classes.." SystemOrganization removeSystemCategory: 'Graphics-Files'. SystemOrganization removeSystemCategory: 'System-Object Storage'. self removeClassNamed: #ProjectController. self removeClassNamed: #ProjectView. "Smalltalk removeClassNamed: #Project." self removeClassNamed: #Environment. self removeClassNamed: #Component1. self removeClassNamed: #FormSetFont. self removeClassNamed: #FontSet. self removeClassNamed: #InstructionPrinter. self removeClassNamed: #ChangeSorter. self removeClassNamed: #DualChangeSorter. self removeClassNamed: #EmphasizedMenu. self removeClassNamed: #MessageTally. StringHolder class removeSelector: #originalWorkspaceContents. CompiledMethod removeSelector: #symbolic. RemoteString removeSelector: #makeNewTextAttVersion. Utilities class removeSelector: #absorbUpdatesFromServer. self removeClassNamed: #PenPointRecorder. self removeClassNamed: #Path. self removeClassNamed: #Base64MimeConverter. "Smalltalk removeClassNamed: #EToySystem. Dont bother - its very small and used for timestamps etc" self removeClassNamed: #RWBinaryOrTextStream. self removeClassNamed: #AttributedTextStream. self removeClassNamed: #WordNet. self removeClassNamed: #SelectorBrowser. TextStyle allSubInstancesDo: [:ts | ts newFontArray: (ts fontArray copyFrom: 1 to: (2 min: ts fontArray size))]. ListParagraph initialize. PopUpMenu initialize. "rbb 2/18/2005 09:21 - How should this change for UIManger?" StandardSystemView initialize. ChangeSet noChanges. ChangeSorter classPool at: #AllChangeSets put: (OrderedCollection with: ChangeSet current). SystemDictionary removeSelector: #majorShrink. [self removeAllUnSentMessages > 0] whileTrue: [Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]]. SystemOrganization removeEmptyCategories. self allClassesDo: [:c | c zapOrganization]. self garbageCollect. 'Rehashing method dictionaries . . .' displayProgressAt: Sensor cursorPoint from: 0 to: MethodDictionary instanceCount during: [:bar | oldDicts := MethodDictionary allInstances. newDicts := Array new: oldDicts size. oldDicts withIndexDo: [:d :index | bar value: index. newDicts at: index put: d rehashWithoutBecome]. oldDicts elementsExchangeIdentityWith: newDicts]. oldDicts := newDicts := nil. Project rebuildAllProjects. ChangeSet current initialize. "seems to take more than one try to gc all the weak refs in SymbolTable " 3 timesRepeat: [self garbageCollect. Symbol compactSymbolTable]! ! !SystemNavigation methodsFor: 'browse' stamp: 'rbb 2/18/2005 14:43'! browseClassVarRefs: aClass "Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods that refer to the selected class variable" | lines labelStream vars allVars index owningClasses | lines _ OrderedCollection new. allVars _ OrderedCollection new. owningClasses _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). aClass withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var. owningClasses add: class]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (UIManager default chooseFrom: (labelStream contents substrings) lines: lines). index = 0 ifTrue: [^ self]. self browseAllCallsOn: ((owningClasses at: index) classPool associationAt: (allVars at: index))! ! !SystemNavigation methodsFor: 'browse' stamp: 'rbb 2/18/2005 14:49'! browseMessageList: messageList name: labelString autoSelect: autoSelectString | title aSize | "Create and schedule a MessageSet browser on the message list." messageList size = 0 ifTrue: [^ (self inform: 'There are no ' , labelString)]. title _ (aSize _ messageList size) > 1 ifFalse: [labelString] ifTrue: [ labelString, ' [', aSize printString, ']']. MessageSet openMessageList: messageList name: title autoSelect: autoSelectString! ! !SystemNavigation methodsFor: 'ui' stamp: 'rbb 2/18/2005 14:48'! confirmRemovalOf: aSelector on: aClass "Determine if it is okay to remove the given selector. Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed." | count answer caption allCalls | allCalls _ self allCallsOn: aSelector. (count _ allCalls size) == 0 ifTrue: [^ 1]. "no senders -- let the removal happen without warning" count == 1 ifTrue: [(allCalls first actualClass == aClass and: [allCalls first methodSymbol == aSelector]) ifTrue: [^ 1]]. "only sender is itself" caption _ 'This message has ' , count printString , ' sender'. count > 1 ifTrue: [caption _ caption copyWith: $s]. answer _ UIManager default chooseFrom: #('Remove it' 'Remove, then browse senders' 'Don''t remove, but show me those senders' 'Forget it -- do nothing -- sorry I asked') title: caption. answer == 3 ifTrue: [self browseMessageList: allCalls name: 'Senders of ' , aSelector autoSelect: aSelector keywords first]. answer == 0 ifTrue: [answer _ 3]. "If user didn't answer, treat it as cancel" ^ answer min: 3! ! !SystemNavigation methodsFor: 'ui' stamp: 'rbb 2/18/2005 14:50'! showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock withCaption: aCaption "Show a sorted menu of the given selectors, preceded by firstItem, and all abbreviated to 40 characters. Use aCaption as the menu title, if it is not nil. Evaluate choiceBlock if a message is chosen." | index menuLabels sortedList aMenu | sortedList _ selectorCollection asSortedCollection. menuLabels _ String streamContents: [:strm | strm nextPutAll: (firstItem contractTo: 40). sortedList do: [:sel | strm cr; nextPutAll: (sel contractTo: 40)]]. aMenu _ UIManager default chooseFrom: (menuLabels substrings) lines: #(1). index _ aCaption ifNotNil: [aMenu startUpWithCaption: aCaption] ifNil: [aMenu startUp]. index = 1 ifTrue: [choiceBlock value: firstItem]. index > 1 ifTrue: [choiceBlock value: (sortedList at: index - 1)]! ! !Text methodsFor: 'attributes' stamp: 'rbb 2/18/2005 09:14'! askIfAddStyle: priorMethod req: requestor "Ask the user if we have a complex style (i.e. bold) for the first time" | tell answ old | (Preferences browseWithPrettyPrint and: [Preferences colorWhenPrettyPrinting]) ifTrue: [self couldDeriveFromPrettyPrinting ifTrue: [^ self asString]]. self runs coalesce. self unembellished ifTrue: [^ self asString]. priorMethod ifNotNil: [old _ priorMethod getSourceFromFile]. (old == nil or: [old unembellished]) ifTrue: [tell _ 'This method contains style for the first time (e.g. bold or colored text). Do you really want to save the style info?'. answ _ (UIManager default chooseFrom: #('Save method with style' 'Save method simply') title: tell). answ = 2 ifTrue: [^ self asString]]! ! !TextMessageLink methodsFor: 'acting' stamp: 'rbb 2/18/2005 09:33'! actOnClickFor: evt | choice viewMsg | viewMsg _ message containsViewableImage ifTrue: ['view this image attachment'] ifFalse: ['view this attachment']. choice _ UIManager default chooseFrom: (Array with: viewMsg with: 'save this attachment' ). choice = 1 ifTrue: ["open a new viewer" message viewBody]. choice = 2 ifTrue: ["save the mesasge" message save]. ^ true! ! !TextStyle class methodsFor: 'instance creation' stamp: 'rbb 2/18/2005 13:18'! changeDefaultFontSizeBy: delta "TextStyle changeDefaultFontSizeBy: 1" "This sample method recreates the default textStyle, with font 1 being a size larger than the smallest. It then initializes most references in the system as well, although most windows will have to beclosed and reopened to get the effect." | allFonts | allFonts _ TextStyle default fontArray asSortedCollection: [:a :b | a height < b height]. TextConstants at: #DefaultTextStyle put: (TextStyle fontArray: ((1 to: allFonts size) collect: [:i | allFonts atWrap: i+delta])). "rbb 2/18/2005 13:18 - How should this work for UIManager?" PopUpMenu initialize. "Change this method for difft menu font" ListParagraph initialize. "Change this method for difft ListPane font" StandardSystemView initialize. "Change this method for difft Window label font" ! ! !TextURL methodsFor: 'as yet unclassified' stamp: 'rbb 2/18/2005 09:24'! actOnClickFor: anObject "Do what you can with this URL. Later a web browser." | response m | (url beginsWith: 'sqPr://') ifTrue: [ ProjectLoading thumbnailFromUrl: (url copyFrom: 8 to: url size). ^self "should not get here, but what the heck" ]. "if it's a web browser, tell it to jump" anObject isWebBrowser ifTrue: [anObject jumpToUrl: url. ^ true] ifFalse: [((anObject respondsTo: #model) and: [anObject model isWebBrowser]) ifTrue: [anObject model jumpToUrl: url. ^ true]]. "if it's a morph, see if it is contained in a web browser" (anObject isKindOf: Morph) ifTrue: [ m _ anObject. [ m ~= nil ] whileTrue: [ (m isWebBrowser) ifTrue: [ m jumpToUrl: url. ^true ]. (m hasProperty: #webBrowserView) ifTrue: [ m model jumpToUrl: url. ^true ]. m _ m owner. ] ]. "no browser in sight. ask if we should start a new browser" ((self confirm: 'open a browser to view this URL?' translated) and: [WebBrowser default notNil]) ifTrue: [ WebBrowser default openOnUrl: url. ^ true ]. "couldn't display in a browser. Offer to put up just the source" response _ (UIManager default chooseFrom: (Array with: 'View web page as source' translated with: 'Cancel' translated) title: 'Couldn''t find a web browser. View\page as source?' withCRs translated). response = 1 ifTrue: [HTTPSocket httpShowPage: url]. ^ true! ! !Utilities class methodsFor: 'common requests' stamp: 'rbb 2/18/2005 13:11'! offerCommonRequests "Offer up the common-requests menu. If the user chooses one, then evaluate it, and -- provided the value is a number or string -- show it in the Transcript." "Utilities offerCommonRequests" | reply result aMenu index normalItemCount strings | Smalltalk isMorphic ifTrue: [^ self offerCommonRequestsInMorphic]. (CommonRequestStrings == nil or: [CommonRequestStrings isKindOf: Array]) ifTrue: [self initializeCommonRequestStrings]. strings _ CommonRequestStrings contents. normalItemCount _ strings asString lineCount. aMenu _ UIManager default chooseFrom: (((strings asString, '\edit this menu' withCRs) findTokens: Character cr) asArray) lines: (Array with: normalItemCount). index _ aMenu startUp. index == 0 ifTrue: [^ self]. reply _ aMenu labelString lineNumber: index. reply size == 0 ifTrue: [^ self]. index > normalItemCount ifTrue: [^ self editCommonRequestStrings]. result _ self evaluate: reply in: nil to: nil. (result isNumber) | (result isString) ifTrue: [Transcript cr; nextPutAll: result printString]! ! !Utilities class methodsFor: 'fetching updates' stamp: 'rbb 2/18/2005 13:14'! chooseUpdateList "When there is more than one set of update servers, let the user choose which we will update from. Put it at the front of the list. Return false if the user aborted. If the preference #promptForUpdateServer is false, then suppress that prompt, in effect using the same server choice that was used the previous time (a convenience for those of us who always answer the same thing to the prompt.)" | index him | ((UpdateUrlLists size > 1) and: [Preferences promptForUpdateServer]) ifTrue: [index _ UIManager default chooseFrom: (UpdateUrlLists collect: [:each | each first]) lines: #() title: 'Choose a group of servers\from which to fetch updates.' withCRs. index > 0 ifTrue: [him _ UpdateUrlLists at: index. UpdateUrlLists removeAt: index. UpdateUrlLists addFirst: him]. ^ index > 0]. ^ true! ! !Utilities class methodsFor: 'fetching updates' stamp: 'rbb 2/18/2005 13:16'! readServerUpdatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage "Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load. This makes it possible to update only up to a particular point. If saveLocally is true, then save local copies of the update files on disc. If updateImage is true, then absorb the updates into the current image. A file on the server called updates.list has the names of the last N update files. We look backwards for the first one we do not have, and start there" "* To add a new update: Name it starting with a new two-digit code. * Do not use %, /, *, space, or more than one period in the name of an update file. * The update name does not need to have any relation to the version name. * Figure out which versions of the system the update makes sense for. * Add the name of the file to each version's category below. * Put this file and the update file on all of the servers. * * To make a new version of the system: Pick a name for it (no restrictions) * Put # and exactly that name on a new line at the end of this file. * During the release process, fill in exactly that name in the dialog box. * Put this file on the server." "When two sets of updates need to use the same directory, one of them has a * in its serverUrls description. When that is true, the first word of the description is put on the front of 'updates.list', and that is the index file used." "Utilities readServerUpdatesThrough: 3922 saveLocally: true updateImage: true" | failed loaded str res servers triple tryAgain indexPrefix | Utilities chooseUpdateList ifFalse: [^ self]. "ask the user which kind of updates" servers _ Utilities serverUrls copy. indexPrefix _ (Utilities updateUrlLists first first includes: $*) ifTrue: [(Utilities updateUrlLists first first findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" [servers isEmpty] whileFalse: [ triple _ self readServer: servers special: indexPrefix updatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage. "report to user" failed _ triple first. loaded _ triple second. tryAgain _ false. failed ifNil: ["is OK" loaded = 0 ifTrue: ["found no updates" servers size > 1 ifTrue: ["not the last server" res _ UIManager default chooseFrom: #('Stop looking' 'Try next server') title: 'No new updates on the server ', servers first, ' Would you like to try the next server? (Normally, all servers are identical, but sometimes a server won''t let us store new files, and gets out of date.)' . res = 2 ifFalse: [^ self] ifTrue: [servers _ servers allButFirst. "try the next server" tryAgain _ true]]]]. tryAgain ifFalse: [ str _ loaded printString ,' new update file(s) processed.'. ^ self inform: str]. ].! ! !Utilities class methodsFor: 'summer97 additions' stamp: 'rbb 2/18/2005 13:13'! classFromPattern: pattern withCaption: aCaption "If there is a class whose name exactly given by pattern, return it. If there is only one class in the system whose name matches pattern, return it. Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. This method ignores tab, space, & cr characters in the pattern" | toMatch potentialClassNames classNames exactMatch index | (toMatch _ pattern copyWithoutAll: {Character space. Character cr. Character tab}) isEmpty ifTrue: [^ nil]. Symbol hasInterned: toMatch ifTrue: [:patternSymbol | Smalltalk at: patternSymbol ifPresent: [:maybeClass | (maybeClass isKindOf: Class) ifTrue: [^ maybeClass]]]. toMatch _ (toMatch copyWithout: $.) asLowercase. potentialClassNames _ Smalltalk classNames asOrderedCollection. classNames _ pattern last = $. ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. classNames isEmpty ifTrue: [^ nil]. exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil]. index _ classNames size = 1 ifTrue: [1] ifFalse: [exactMatch ifNil: [UIManager default chooseFrom: classNames lines: #() title: aCaption] ifNotNil: [classNames addFirst: exactMatch. UIManager default chooseFrom: classNames lines: #(1) title: aCaption]]. index = 0 ifTrue: [^ nil]. ^ Smalltalk at: (classNames at: index) asSymbol " Utilities classFromPattern: 'CharRecog' Utilities classFromPattern: 'rRecog' Utilities classFromPattern: 'znak' Utilities classFromPattern: 'orph' " ! ! !WordNet class methodsFor: 'miscellaneous' stamp: 'rbb 2/18/2005 12:36'! languagePrefs "Set preference of which natural language is primary. Look up definitions in it, and correct speaLanguageing in it. Also, let user set languages to translate from and to." | ch aLanguage | self canTranslateFrom. "sets defaults" ch _ (UIManager default chooseFrom: (Array with: 'word definition and spelling verification (', (Preferences parameterAt: #myLanguage ifAbsentPut: [#English]) asString ,')...\' with: 'language to translate FROM (now ', (Preferences parameterAt: #languageTranslateFrom ifAbsentPut: [#English]) asString ,')...\' with: 'language to translate TO (now ', (Preferences parameterAt: #languageTranslateTo ifAbsentPut: [#German]) asString ,')...\') title: 'Choose the natural language to use for:') ch = 1 ifTrue: [ aLanguage _ UIManager default chooseFrom: Languages title: 'The language for word definitions and speaLanguageing verification:'. aLanguage > 0 ifTrue: [^ Preferences setParameter: #myLanguage to: (Languages at: aLanguage) asSymbol]]. ch = 2 ifTrue: [aLanguage _ UIManager default chooseFrom: CanTranslateFrom title: 'The language to translate from:'. aLanguage > 0 ifTrue: [^ Preferences setParameter: #languageTranslateFrom to: (CanTranslateFrom at: aLanguage) asSymbol]]. ch = 3 ifTrue: [aLanguage _ UIManager default chooseFrom: CanTranslateFrom title: 'The language to translate to'. aLanguage > 0 ifTrue: [^ Preferences setParameter: #languageTranslateTo to: (CanTranslateFrom at: aLanguage) asSymbol]]. "Maybe let the user add another language if he knows the server can take it." " ch _ (UIManager default chooseFrom: Languages, {'other...'. 'Choose language to translate from...'} title: 'Choose the language of dictionary for word definitions.'). ch = 0 ifTrue: [^ Preferences setParameter: #myLanguage to: #English]. (ch <= Languages size) ifTrue: [aLanguage _ Languages at: ch]. ch = (Languages size + 1) ifTrue: [ aLanguage _ FillInTheBlank request: 'Name of the primary language']. aLanguage ifNotNil: [^ Preferences setParameter: #myLanguage to: aLanguage asSymbol]. "! ! !ZipArchiveMember methodsFor: 'extraction' stamp: 'rbb 2/18/2005 14:42'! extractInDirectory: aDirectory overwrite: overwriteAll "Extract this entry into the given directory. Answer #okay, #failed, #abort, or #retryWithOverwrite." | path fileDir file index localName | path := fileName findTokens:'/'. localName := path last. fileDir := path allButLast inject: aDirectory into:[:base :part| base directoryNamed: part]. fileDir assureExistence. file := [fileDir newFileNamed: localName] on: FileExistsException do:[:ex| ex return: nil]. file ifNil:[ overwriteAll ifFalse:[ [index := UIManager default chooseFrom: { 'Yes, overwrite'. 'No, don''t overwrite'. 'Overwrite ALL files'. 'Cancel operation' } lines: #(2) title: fileName, ' already exists. Overwrite?'. index == nil] whileTrue. index = 4 ifTrue:[^#abort]. index = 3 ifTrue:[^#retryWithOverwrite]. index = 2 ifTrue:[^#okay]. ]. file := [fileDir forceNewFileNamed: localName] on: Error do:[:ex| ex return]. file ifNil:[^#failed]. ]. self extractTo: file. file close. ^#okay! !