[squeak-dev] The Inbox: Tools-eem.1168.mczcommits at source.squeak.org commits at source.squeak.orgThu Jul 14 14:11:30 UTC 2022
A new version of Tools was added to project The Inbox: http://source.squeak.org/inbox/Tools-eem.1168.mcz ==================== Summary ==================== Name: Tools-eem.1168 Author: eem Time: 13 July 2022, 4:29:53.654209 pm UUID: 3ce13884-de6d-4e9d-8ada-6eca4fd59835 Ancestors: Tools-eem.1167 Refactor selectMethodsForThisClass & selectSuchThat: so that any of selectMethodsForThisClass, selectMethodsForExtantClasses, & selectContentsMatching can extend selections via the shift key. =============== Diff against Tools-eem.1167 =============== Item was removed: - (PackageInfo named: 'Tools') preamble: '(Workspace instVarNames includes: #windowTitle) - ifFalse: [Workspace addInstVarName: #windowTitle]. - (Workspace instVarNames includes: #fileDirectory) - ifFalse: [Workspace addInstVarName: #fileDirectory]. - (Workspace instVarNames includes: #fileLineEndConvention) - ifFalse: [Workspace addInstVarName: #fileLineEndConvention]. - - Workspace allInstancesDo: [:workspace | - workspace instVarNamed: #windowTitle - put: (workspace valueOfProperty: #windowTitle). - workspace instVarNamed: #fileDirectory - put: (workspace valueOfProperty: #fileDirectory). - workspace instVarNamed: #fileLineEndConvention - put: (workspace valueOfProperty: #fileLineConversion)]. - '! Item was removed: - SystemOrganization addCategory: #'Tools-ArchiveViewer'! - SystemOrganization addCategory: #'Tools-Base'! - SystemOrganization addCategory: #'Tools-Browser'! - SystemOrganization addCategory: #'Tools-Changes'! - SystemOrganization addCategory: #'Tools-Debugger'! - SystemOrganization addCategory: #'Tools-Explorer'! - SystemOrganization addCategory: #'Tools-File Contents Browser'! - SystemOrganization addCategory: #'Tools-FileList'! - SystemOrganization addCategory: #'Tools-Inspector'! - SystemOrganization addCategory: #'Tools-Menus'! - SystemOrganization addCategory: #'Tools-MethodFinder'! - SystemOrganization addCategory: #'Tools-Process Browser'! Item was removed: - ----- Method: AbstractFont>>browseAllGlyphs (in category '*Tools-Browsing') ----- - browseAllGlyphs - "Browse glyphs for all printable characters/code-points in the receiver." - - ^ self browseGlyphsFrom: self minCodePoint to: self maxCodePoint! Item was removed: - ----- Method: AbstractFont>>browseAllGlyphsByCategory (in category '*Tools-Browsing') ----- - browseAllGlyphsByCategory - "Browse glyphs for all printable characters/code-points in the receiver." - - ^ self - browseGlyphsByCategoryOf: ((self minCodePoint max: 32 "space"+1) to: self maxCodePoint) - select: [:char | self hasGlyphOf: char]! Item was removed: - ----- Method: AbstractFont>>browseAllGlyphsScaledToDisplay (in category '*Tools-Browsing') ----- - browseAllGlyphsScaledToDisplay - "Browse all glyphs from the receiver's fontFamily in the system's default #pointSize." - - (self asPointSize: TextStyle defaultFont pointSize) browseAllGlyphs. - - "(self textStyle fontOfPointSize: TextStyle defaultFont pointSize) browseAllGlyphs."! Item was removed: - ----- Method: AbstractFont>>browseAllSymbols (in category '*Tools-Browsing') ----- - browseAllSymbols - "This is a variation of #browseAllGlyphs that is optimized to show all available glyphs in a single run, even though their code points may be scattered all over the Unicode range. See #browseAllSymbolsByCategory." - - "self isSymbolFont ifFalse: [self notify: 'This is not a symbol font: ', self familyName]." - - ^ self - browseGlyphsOf: (((self minCodePoint max: 16r1000) to: self maxCodePoint) select: [:ea | self hasGlyphForCode: ea]) - label: 'All symbols in ', self familyName! Item was removed: - ----- Method: AbstractFont>>browseAllSymbolsByCategory (in category '*Tools-Browsing') ----- - browseAllSymbolsByCategory - - self isSymbolFont ifFalse: [self notify: 'This is not a symbol font: ', self familyName]. - ^ self browseAllGlyphsByCategory! Item was removed: - ----- Method: AbstractFont>>browseGlyphsByCategoryOf: (in category '*Tools-Browsing') ----- - browseGlyphsByCategoryOf: someCodePointsOrCharacters - - self browseGlyphsByCategoryOf: someCodePointsOrCharacters label: nil.! Item was removed: - ----- Method: AbstractFont>>browseGlyphsByCategoryOf:label: (in category '*Tools-Browsing') ----- - browseGlyphsByCategoryOf: someCodePointsOrCharacters label: label - - self - browseGlyphsByCategoryOf: someCodePointsOrCharacters - select: [:char | true] - label: label! Item was removed: - ----- Method: AbstractFont>>browseGlyphsByCategoryOf:select: (in category '*Tools-Browsing') ----- - browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock - - self browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: nil.! Item was removed: - ----- Method: AbstractFont>>browseGlyphsByCategoryOf:select:label: (in category '*Tools-Browsing') ----- - browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil - "Like #browseGlyphsOf:... but group the code points by Unicode category." - - | sortedCodePoints contents isRange tmp separatorBlock | - isRange := isRange := someCodePointsOrCharacters isInterval and: [someCodePointsOrCharacters increment = 1]. - - separatorBlock := [:codePoints :category | - (('\{1}\\' withCRs asText - format: { Unicode generalCategoryLabels at: category+1 ifAbsent: ['n/a'] }) - addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont); - addAttribute: (PluggableTextAttribute evalBlock: [self browseGlyphsByCategoryOf: codePoints select: aBlock label: aLabelOrNil]); - yourself) ]. - - sortedCodePoints := (someCodePointsOrCharacters - collect: [:ea | ea isCharacter ifTrue: [ea charCode] ifFalse: [ea] ] - thenSelect: [:ea | aBlock value: (Unicode value: ea)]) - sorted: [:a :b | | ca cb | (ca := (Unicode generalCategoryOf: a) ifNil: [0]) < (cb := (Unicode generalCategoryOf: b) ifNil: [0]) - or: [ca = cb and: [a < b]]]. - - "Header" - contents := (('Family name: {1}{6}\ Emphasis: {2}\ Point size: {3} ({4}ppi {5}px{7})\' withCRs asText format: { self familyName asText addAttribute: (PluggableTextAttribute evalBlock: [self explore]); yourself. [self emphasisString] on: Error do: [self subfamilyName]. self pointSize. self pixelsPerInch. self height. isRange ifTrue: [''] ifFalse: [' (selected code points)']. (self isTTCFont and: [(tmp := self extraGlyphScale) ~= 1]) ifFalse: [''] ifTrue: [' ', (tmp * 100) rounded asString, '%'] }) addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont); yourself). - - String streamContents: [:s | | priorCategory currentCodePoints | - currentCodePoints := OrderedCollection new. - sortedCodePoints withIndexDo: [:codePoint :index | - | char category | - char := Unicode value: codePoint. - category := Unicode generalCategoryOf: codePoint. - priorCategory ifNil: [priorCategory := category]. - category = priorCategory ifTrue: [ - currentCodePoints add: codePoint. - s nextPut: char]. - (category ~= priorCategory or: [index = sortedCodePoints size]) - ifTrue: [ - contents := contents, (separatorBlock value: currentCodePoints value: priorCategory). - contents := contents, ((s cr; contents) asText addAttribute: (TextFontReference toFont: self); yourself). - currentCodePoints := OrderedCollection new. - s reset. - currentCodePoints add: codePoint. - s nextPut: char]. - (self widthOf: char) = 0 ifTrue: [s nextPut: Character nbsp; nextPut: Character nbsp]. - priorCategory := category]]. - - contents editWithLabel: (aLabelOrNil ifNil: [self printString]).! Item was removed: - ----- Method: AbstractFont>>browseGlyphsFrom:to: (in category '*Tools-Browsing') ----- - browseGlyphsFrom: firstCodePoint to: lastCodePoint - "Split range in sub-ranges whenever the receiver has no glyph for a certain code point or when that glyph is not visible. Start with at least a printable character after #space to avoid line breaks in the editor. Note that non-breaking space an similar are skipped as well." - - ^ self - browseGlyphsOf: - ((firstCodePoint max: (self minCodePoint max: 32 "space" +1)) - to: (lastCodePoint min: self maxCodePoint)) - select: [:char | self hasGlyphOf: char]! Item was removed: - ----- Method: AbstractFont>>browseGlyphsFrom:to:select: (in category '*Tools-Browsing') ----- - browseGlyphsFrom: firstCodePoint to: lastCodePoint select: aBlock - - self - browseGlyphsOf: (firstCodePoint to: lastCodePoint) - select: aBlock.! Item was removed: - ----- Method: AbstractFont>>browseGlyphsOf: (in category '*Tools-Browsing') ----- - browseGlyphsOf: someCodePointsOrCharacters - - self browseGlyphsOf: someCodePointsOrCharacters label: nil.! Item was removed: - ----- Method: AbstractFont>>browseGlyphsOf:label: (in category '*Tools-Browsing') ----- - browseGlyphsOf: someCodePointsOrCharacters label: label - "Browse a collection of non-sequential code points or characters. For ranges use #browseGlyphsFrom:to: to then split into sub-ranges via prediate. - - self browseGlyphsOf: 'Hello' - " - - self - browseGlyphsOf: someCodePointsOrCharacters - select: [:char | true] - label: label! Item was removed: - ----- Method: AbstractFont>>browseGlyphsOf:select: (in category '*Tools-Browsing') ----- - browseGlyphsOf: someCodePointsOrCharacters select: aBlock - - self browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: nil.! Item was removed: - ----- Method: AbstractFont>>browseGlyphsOf:select:label: (in category '*Tools-Browsing') ----- - browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil - "Browse all glyphs in the given collection of code points or characters. Split range in sub-ranges whenever the receiver has no glyph for a certain code point. DO NOT translate user-facing text because this is a debugging tool so that text should only use ASCII." - - | contents isRange tmp separatorBlock | - isRange := someCodePointsOrCharacters isInterval and: [someCodePointsOrCharacters increment = 1]. - - separatorBlock := [:currentRange | - (('\16r{1} to: 16r{2}\\' withCRs asText - format: { currentRange first printStringBase: 16 length: 6 padded: true. currentRange last printStringBase: 16 length: 6 padded: true }) - addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont); - addAttribute: (PluggableTextAttribute evalBlock: [self browseGlyphsFrom: currentRange first to: currentRange last select: aBlock]); - yourself)]. - - "Header" - contents := (('Family name: {1}{6}\ Emphasis: {2}\ Point size: {3} ({4}ppi {5}px{7})\' withCRs asText format: { self familyName asText addAttribute: (PluggableTextAttribute evalBlock: [self explore]); yourself. [self emphasisString] on: Error do: [self subfamilyName]. self pointSize. self pixelsPerInch. self height. isRange ifTrue: [''] ifFalse: [' (selected code points)']. (self isTTCFont and: [(tmp := self extraGlyphScale) ~= 1]) ifFalse: [''] ifTrue: [' ', (tmp * 100) rounded asString, '%'] }) addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont); yourself). - - String streamContents: [:s | | first last | - last := someCodePointsOrCharacters last. - someCodePointsOrCharacters withIndexDo: [:codePointOrChar :index | - | current char valid | - current := codePointOrChar isCharacter ifTrue: [codePointOrChar charCode] ifFalse: [codePointOrChar]. - char := Unicode value: current. - (valid := (aBlock value: char)) - ifTrue: [ - s position = 0 ifTrue: [first := current]. - s nextPut: char. - (self widthOf: char) = 0 ifTrue: [s nextPut: Character nbsp; nextPut: Character nbsp] ]. - (valid not or: [index = someCodePointsOrCharacters size]) - ifTrue: [s position = 0 ifFalse: [ - isRange ifFalse: [contents := contents, String cr] ifTrue: [ | currentRange | - currentRange := first to: (index = someCodePointsOrCharacters size ifTrue: [last] ifFalse: [current-1]). - contents := contents, (separatorBlock value: currentRange)]. - contents := contents, ((s cr; contents) asText addAttribute: (TextFontReference toFont: self); yourself). - s reset]] ]]. - - contents editWithLabel: (aLabelOrNil ifNil: [self printString]).! Item was removed: - SystemWindow subclass: #ArchiveViewer - instanceVariableNames: 'archive fileName memberIndex viewAllContents' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-ArchiveViewer'! - - !ArchiveViewer commentStamp: '<historical>' prior: 0! - This is a viewer window that allows editing and viewing of Zip archives.! Item was removed: - ----- Method: ArchiveViewer class>>addFileToNewZip: (in category 'instance creation') ----- - addFileToNewZip: fullName - - "Add the currently selected file to a new zip" - | zip | - zip := (ZipArchive new) - addFile: fullName - as: (FileDirectory localNameFor: fullName); yourself. - (self open) archive: zip - ! Item was removed: - ----- Method: ArchiveViewer class>>deleteTemporaryDirectory (in category 'class initialization') ----- - deleteTemporaryDirectory - " - ArchiveViewer deleteTemporaryDirectory - " - - | dir | - (dir := self temporaryDirectory) exists ifTrue: [ dir recursiveDelete ].! Item was removed: - ----- Method: ArchiveViewer class>>descriptionForPartsBin (in category 'parts bin') ----- - descriptionForPartsBin - - ^ self partName: 'Zip Tool' translatedNoop - categories: {'Tools' translated} - documentation: 'A viewer and editor for Zip archive files' translatedNoop - ! Item was removed: - ----- Method: ArchiveViewer class>>extractAllFrom: (in category 'file list services') ----- - extractAllFrom: aFileName - (self new) fileName: aFileName; extractAll! Item was removed: - ----- Method: ArchiveViewer class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') ----- - fileReaderServicesForFile: fullName suffix: suffix - - | services | - services := OrderedCollection new. - services add: self serviceAddToNewZip. - ({'zip'.'sar'.'pr'. 'mcz'. '*'} includes: suffix) - ifTrue: [services add: self serviceOpenInZipViewer. - services add: self serviceExtractAll]. - ^ services! Item was removed: - ----- Method: ArchiveViewer class>>initialize (in category 'class initialization') ----- - initialize - "ArchiveViewer initialize" - - FileServices registerFileReader: self. - Smalltalk addToShutDownList: self.! Item was removed: - ----- Method: ArchiveViewer class>>open (in category 'instance creation') ----- - open - ^(self new) createWindow; openInWorld.! Item was removed: - ----- Method: ArchiveViewer class>>openOn: (in category 'instance creation') ----- - openOn: aFileName - | newMe | - newMe := self new. - newMe createWindow; fileName: aFileName; openInWorld. - ^newMe! Item was removed: - ----- Method: ArchiveViewer class>>serviceAddToNewZip (in category 'file list services') ----- - serviceAddToNewZip - "Answer a service for adding the file to a new zip" - - ^ FileModifyingSimpleServiceEntry - provider: self - label: 'add file to new zip' translatedNoop - selector: #addFileToNewZip: - description: 'add file to new zip' translatedNoop - buttonLabel: 'to new zip' translatedNoop! Item was removed: - ----- Method: ArchiveViewer class>>serviceExtractAll (in category 'file list services') ----- - serviceExtractAll - "Answer a service for opening in a zip viewer" - - ^ FileModifyingSimpleServiceEntry - provider: self - label: 'extract all to...' translatedNoop - selector: #extractAllFrom: - description: 'extract all files to a user-specified directory' translatedNoop - buttonLabel: 'extract all' translatedNoop! Item was removed: - ----- Method: ArchiveViewer class>>serviceOpenInZipViewer (in category 'class initialization') ----- - serviceOpenInZipViewer - "Answer a service for opening in a zip viewer" - - ^ SimpleServiceEntry - provider: self - label: 'open in zip viewer' translatedNoop - selector: #openOn: - description: 'open in zip viewer' translatedNoop - buttonLabel: 'open zip' translatedNoop! Item was removed: - ----- Method: ArchiveViewer class>>services (in category 'fileIn/Out') ----- - services - - ^ Array - with: self serviceAddToNewZip - with: self serviceOpenInZipViewer - - - ! Item was removed: - ----- Method: ArchiveViewer class>>shutDown: (in category 'class initialization') ----- - shutDown: quitting - quitting ifTrue: [ self deleteTemporaryDirectory ].! Item was removed: - ----- Method: ArchiveViewer class>>temporaryDirectory (in category 'fileIn/Out') ----- - temporaryDirectory - "Answer a directory to use for unpacking files for the file list services." - ^FileDirectory default directoryNamed: '.archiveViewerTemp'! Item was removed: - ----- Method: ArchiveViewer class>>unload (in category 'initialize-release') ----- - unload - - FileServices unregisterFileReader: self ! Item was removed: - ----- Method: ArchiveViewer>>addDirectory (in category 'member operations') ----- - addDirectory - | directory | - self canAddMember ifFalse: [ ^self ]. - directory := UIManager default chooseDirectory. - directory - ifNil: [^ self]. - - archive addTree: directory removingFirstCharacters: directory pathName size + 1. - self memberIndex: 0. - self changed: #memberList.! Item was removed: - ----- Method: ArchiveViewer>>addMember (in category 'member operations') ----- - addMember - | local fName | - self canAddMember ifFalse: [ ^self ]. - fName := UIManager default chooseFileMatching: '*' . - fName ifNil: [ ^self ]. - - local := FileDirectory localNameFor: fName. - (archive addFile: fName as: local) - desiredCompressionMethod: ZipArchive compressionDeflated. - self memberIndex: self members size. - self changed: #memberList.! Item was removed: - ----- Method: ArchiveViewer>>addMemberFromClipboard (in category 'member operations') ----- - addMemberFromClipboard - | string newName | - self canAddMember ifFalse: [ ^self ]. - string := Clipboard clipboardText asString. - newName := UIManager default - request: 'New name for member:' - initialAnswer: 'clipboardText'. - newName notEmpty ifTrue: [ - (archive addString: string as: newName) desiredCompressionMethod: ZipArchive compressionDeflated. - self memberIndex: self members size. - self changed: #memberList. - ] - ! Item was removed: - ----- Method: ArchiveViewer>>archive (in category 'accessing') ----- - archive - ^archive! Item was removed: - ----- Method: ArchiveViewer>>archive: (in category 'initialization') ----- - archive: aZipArchive - archive := aZipArchive. - self model: aZipArchive. - self setLabel: 'New Zip Archive'. - self memberIndex: 0. - self changed: #memberList! Item was removed: - ----- Method: ArchiveViewer>>briefContents (in category 'initialization') ----- - briefContents - "Trim to 5000 characters. If the member is longer, then point out that it is trimmed. - Also warn if the member has a corrupt CRC-32." - - | stream subContents errorMessage | - self selectedMember ifNil: [^ '']. - errorMessage := ''. - stream := WriteStream on: (String new: (self selectedMember uncompressedSize min: 5500)). - - [ self selectedMember uncompressedSize > 5000 - ifTrue: [ | lastLineEndingIndex tempIndex | - subContents := self selectedMember contentsFrom: 1 to: 5000. - lastLineEndingIndex := subContents lastIndexOf: Character cr. - tempIndex := subContents lastIndexOf: Character lf. - tempIndex > lastLineEndingIndex ifTrue: [lastLineEndingIndex := tempIndex]. - lastLineEndingIndex = 0 - ifFalse: [subContents := subContents copyFrom: 1 to: lastLineEndingIndex]] - ifFalse: [ subContents := self selectedMember contents ]] - on: CRCError do: [ :ex | - errorMessage := String streamContents: [ :s | - s nextPutAll: '[ '; - nextPutAll: (ex messageText copyUpToLast: $( ); - nextPutAll: ' ]' ]. - ex proceed ]. - - (errorMessage isEmpty not or: [ self selectedMember isCorrupt ]) ifTrue: [ - stream nextPutAll: '********** WARNING!! Member is corrupt!! '; - nextPutAll: errorMessage; - nextPutAll: ' **********'; cr ]. - - self selectedMember uncompressedSize > 5000 - ifTrue: [ - stream nextPutAll: 'File '; - print: self selectedMember fileName; - nextPutAll: ' is '; - print: self selectedMember uncompressedSize; - nextPutAll: ' bytes long.'; cr; - nextPutAll: 'Click the ''View All Contents'' button above to see the entire file.'; cr; cr; - nextPutAll: 'Here are the first '; - print: subContents size; - nextPutAll: ' characters...'; cr; - next: 40 put: $-; cr; - nextPutAll: subContents; - next: 40 put: $-; cr; - nextPutAll: '... end of the first '; - print: subContents size; - nextPutAll: ' characters.' ] - ifFalse: [ stream nextPutAll: self selectedMember contents ]. - - ^stream contents - ! Item was removed: - ----- Method: ArchiveViewer>>buildWindowMenu (in category 'menu') ----- - buildWindowMenu - | menu | - menu := super buildWindowMenu. - menu addLine. - menu add: 'inspect archive' target: archive action: #inspect. - menu add: 'write prepending file...' target: self action: #writePrependingFile. - ^menu.! Item was removed: - ----- Method: ArchiveViewer>>buttonColor (in category 'initialization') ----- - buttonColor - ^self defaultBackgroundColor darker! Item was removed: - ----- Method: ArchiveViewer>>buttonOffColor (in category 'initialization') ----- - buttonOffColor - ^self defaultBackgroundColor darker! Item was removed: - ----- Method: ArchiveViewer>>buttonOnColor (in category 'initialization') ----- - buttonOnColor - ^self defaultBackgroundColor! Item was removed: - ----- Method: ArchiveViewer>>canAddMember (in category 'member operations') ----- - canAddMember - ^archive notNil! Item was removed: - ----- Method: ArchiveViewer>>canCreateNewArchive (in category 'archive operations') ----- - canCreateNewArchive - ^true! Item was removed: - ----- Method: ArchiveViewer>>canDeleteMember (in category 'member operations') ----- - canDeleteMember - ^memberIndex > 0! Item was removed: - ----- Method: ArchiveViewer>>canExtractAll (in category 'archive operations') ----- - canExtractAll - ^self members notEmpty! Item was removed: - ----- Method: ArchiveViewer>>canExtractMember (in category 'member operations') ----- - canExtractMember - ^memberIndex > 0! Item was removed: - ----- Method: ArchiveViewer>>canOpenNewArchive (in category 'archive operations') ----- - canOpenNewArchive - ^true! Item was removed: - ----- Method: ArchiveViewer>>canRenameMember (in category 'member operations') ----- - canRenameMember - ^memberIndex > 0! Item was removed: - ----- Method: ArchiveViewer>>canSaveArchive (in category 'archive operations') ----- - canSaveArchive - ^archive notNil! Item was removed: - ----- Method: ArchiveViewer>>canViewAllContents (in category 'member operations') ----- - canViewAllContents - ^memberIndex > 0 and: [ viewAllContents not ]! Item was removed: - ----- Method: ArchiveViewer>>changeViewAllContents (in category 'member operations') ----- - 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! Item was removed: - ----- Method: ArchiveViewer>>commentArchive (in category 'archive operations') ----- - commentArchive - | newName | - archive ifNil: [ ^self ]. - newName := UIManager default - request: 'New comment for archive:' - initialAnswer: archive zipFileComment. - archive zipFileComment: newName.! Item was removed: - ----- Method: ArchiveViewer>>commentMember (in category 'member operations') ----- - commentMember - | newName | - newName := UIManager default - request: 'New comment for member:' - initialAnswer: self selectedMember fileComment. - self selectedMember fileComment: newName.! Item was removed: - ----- Method: ArchiveViewer>>contents (in category 'initialization') ----- - contents - | contents errorMessage | - self selectedMember ifNil: [^ '']. - viewAllContents ifFalse: [^ self briefContents]. - - [ contents := self selectedMember contents ] - on: CRCError - do: [ :ex | errorMessage := String streamContents: [ :stream | - stream nextPutAll: '********** WARNING!! Member is corrupt!! [ '; - nextPutAll: (ex messageText copyUpToLast: $( ); - nextPutAll: '] **********'; cr ]. - ex proceed ]. - - ^self selectedMember isCorrupt - ifFalse: [ contents ] - ifTrue: [ errorMessage, contents ]! Item was removed: - ----- Method: ArchiveViewer>>contents: (in category 'initialization') ----- - contents: aText - self shouldNotImplement.! Item was removed: - ----- Method: ArchiveViewer>>createButtonBar (in category 'initialization') ----- - createButtonBar - | bar | - - bar := AlignmentMorph newRow. - bar - color: self defaultBackgroundColor; - rubberBandCells: false; - vResizing: #shrinkWrap; - cellGap: 6 @ 0. - #(#('new archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('load archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('save archive' #canSaveArchive #saveArchive 'Save this archive under a new name') #('extract all' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('add file' #canAddMember #addMember 'Add a file to this archive') #('add clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('add dir ' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('extract member' #canExtractMember #extractMember 'Extract the selected member to a file') #('delete member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('rename member' #canRenameMember #renameMember 'Rename the selected member') #('view all' #canViewAllContents #changeViewAll Contents 'Toggle the view of all the selected member''s contents')) - do: - [:arr | - | button | - (button := PluggableButtonMorph - on: self - getState: arr second - action: arr third) - vResizing: #spaceFill; - hResizing: #spaceFill; - onColor: self buttonOnColor offColor: self buttonOffColor; - label: arr first withCRs; - setBalloonText: arr fourth. - bar addMorphBack: button]. - ^bar! Item was removed: - ----- Method: ArchiveViewer>>createListHeadingUsingFont: (in category 'initialization') ----- - createListHeadingUsingFont: font - | sm | - sm := StringMorph contents: ' order uncomp comp CRC-32 date time file name'. - font ifNotNil: [ sm font: font ]. - ^(AlignmentMorph newColumn) - color: self defaultBackgroundColor; - addMorph: sm; - yourself.! Item was removed: - ----- Method: ArchiveViewer>>createNewArchive (in category 'archive operations') ----- - createNewArchive - self setLabel: '(new archive)'. - archive := ZipArchive new. - self memberIndex: 0. - self changed: #memberList.! Item was removed: - ----- Method: ArchiveViewer>>createWindow (in category 'initialization') ----- - createWindow - | list heading font text buttonBar | - - font := (TextStyle named: #DefaultFixedTextStyle) - ifNotNil: [ :ts | ts fontArray first]. - - buttonBar := self createButtonBar. - self addMorph: buttonBar - fullFrame: (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0.0) offsets: (0 at 0 corner: 0 at 34)). - - self minimumExtent: (buttonBar fullBounds width + 20) @ 230. - self extent: self minimumExtent. - - heading := self createListHeadingUsingFont: font. - self addMorph: heading - fullFrame: (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0.0) offsets: (0 at 34 corner: 0 at 44)). - - (list := PluggableListMorph new) - on: self list: #memberList - selected: #memberIndex changeSelected: #memberIndex: - menu: #memberMenu:shifted: keystroke: nil. - list color: self defaultBackgroundColor. - - font ifNotNil: [list font: font]. - self addMorph: list - fullFrame: (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0.8) offsets: (0 at 50 corner: 0 at 0)). - - text := PluggableTextMorph on: self - text: #contents accept: nil - readSelection: nil menu: nil. - self addMorph: text - frame: (0 at 0.8 corner: 1.0 at 1.0). - text lock. - - self setLabel: 'Ned''s Zip Viewer'! Item was removed: - ----- Method: ArchiveViewer>>defaultBackgroundColor (in category 'accessing') ----- - defaultBackgroundColor - - ^ Color veryVeryLightGray! Item was removed: - ----- Method: ArchiveViewer>>defaultColor (in category 'accessing') ----- - defaultColor - - ^ Color veryVeryLightGray! Item was removed: - ----- Method: ArchiveViewer>>deleteMember (in category 'member operations') ----- - deleteMember - self canDeleteMember ifFalse: [ ^self ]. - archive removeMember: self selectedMember. - self memberIndex: 0. - self changed: #memberList. - ! Item was removed: - ----- Method: ArchiveViewer>>directory (in category 'accessing') ----- - directory - "For compatibility with file list." - ^self error: 'should use readOnlyStream instead!!'! Item was removed: - ----- Method: ArchiveViewer>>displayLineFor: (in category 'member list') ----- - displayLineFor: aMember - | stream dateTime index | - index := self archive members indexOf: aMember. - stream := WriteStream on: (String new: 60). - dateTime := Time dateAndTimeFromSeconds: aMember lastModTime. - stream - nextPutAll: (index printString padded: #left to: 4 with: $ ); - space; - nextPutAll: (aMember uncompressedSize printString padded: #left to: 8 with: $ ); - space; space; - nextPutAll: (aMember compressedSize printString padded: #left to: 8 with: $ ); - space; space; - nextPutAll: (aMember crc32String ); - space; space. - dateTime first printOn: stream format: #(3 2 1 $- 2 1 2). - stream space; space. - dateTime second print24: true showSeconds: false on: stream. - stream space; space; - nextPutAll: (aMember fileName ). - ^stream contents! Item was removed: - ----- Method: ArchiveViewer>>downMember (in category 'member order') ----- - downMember - | temp | - temp := (self archive members) at: memberIndex. - self archive members at: memberIndex put: (self archive members at: memberIndex + 1). - self archive members at: (memberIndex +1) put: temp. - self memberIndex: 0. - self changed: #memberList.! Item was removed: - ----- Method: ArchiveViewer>>extractAll (in category 'archive operations') ----- - extractAll - | directory | - - self canExtractAll ifFalse: [^ self]. - directory := UIManager default chooseDirectory. - directory - ifNil: [^ self]. - - UIManager default informUserDuring: [:bar| archive extractAllTo: directory informing: bar]. - - - ! Item was removed: - ----- Method: ArchiveViewer>>extractAllPossibleInDirectory: (in category 'archive operations') ----- - 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. - ! Item was removed: - ----- Method: ArchiveViewer>>extractDirectoriesIntoDirectory: (in category 'archive operations') ----- - extractDirectoriesIntoDirectory: directory - (self members select: [:ea | ea isDirectory]) - do: [:ea | ea extractInDirectory: directory]! Item was removed: - ----- Method: ArchiveViewer>>extractFilesIntoDirectory: (in category 'archive operations') ----- - extractFilesIntoDirectory: directory - (self members reject: [:ea | ea isDirectory]) - do: [:ea | ea extractInDirectory: directory]! Item was removed: - ----- Method: ArchiveViewer>>extractMember (in category 'member operations') ----- - extractMember - "Extract the member after prompting for a filename. - Answer the filename, or nil if error." - - | name | - self canExtractMember ifFalse: [ ^nil ]. - name := FileSaverDialog openOn: FileDirectory default. - name ifNil: [ ^nil ]. - (archive canWriteToFileNamed: name) - ifFalse: [ self inform: name, ' is used by one or more members - in your archive, and cannot be overwritten. - Try extracting to another file name'. - ^nil ]. - self selectedMember extractToFileNamed: name. - ^name! Item was removed: - ----- Method: ArchiveViewer>>fileName (in category 'accessing') ----- - fileName - ^fileName! Item was removed: - ----- Method: ArchiveViewer>>fileName: (in category 'initialization') ----- - fileName: aString - archive := ZipArchive new readFrom: aString. - self setLabel: aString. - self memberIndex: 0. - self changed: #memberList! Item was removed: - ----- Method: ArchiveViewer>>fullName (in category 'accessing') ----- - fullName - "For compatibility with FileList services. - If this is called, it means that a service that requires a real filename has been requested. - So extract the selected member to a temporary file and return that name." - - | fullName dir | - self canExtractMember ifFalse: [ ^nil ]. - dir := FileDirectory default directoryNamed: '.archiveViewerTemp'. - fullName := dir fullNameFor: self selectedMember localFileName. - self selectedMember extractInDirectory: dir. - ^fullName! Item was removed: - ----- Method: ArchiveViewer>>highlightMemberList:with: (in category 'member list') ----- - highlightMemberList: list with: morphList - (morphList at: self memberIndex) color: Color red! Item was removed: - ----- Method: ArchiveViewer>>initialize (in category 'initialization') ----- - initialize - super initialize. - memberIndex := 0. - viewAllContents := false. - ! Item was removed: - ----- Method: ArchiveViewer>>initializeToStandAlone (in category 'parts bin') ----- - initializeToStandAlone - self initialize createWindow.! Item was removed: - ----- Method: ArchiveViewer>>inspectMember (in category 'member operations') ----- - inspectMember - self selectedMember inspect! Item was removed: - ----- Method: ArchiveViewer>>memberIndex (in category 'member list') ----- - memberIndex - ^memberIndex! Item was removed: - ----- Method: ArchiveViewer>>memberIndex: (in category 'member list') ----- - memberIndex: n - memberIndex := n. - viewAllContents := false. - self changed: #memberIndex. - self changed: #contents.! Item was removed: - ----- Method: ArchiveViewer>>memberList (in category 'member list') ----- - memberList - ^ self members collect: [ :ea | self displayLineFor: ea ]! Item was removed: - ----- Method: ArchiveViewer>>memberMenu:shifted: (in category 'member list') ----- - memberMenu: menu shifted: shifted - | services | - - menu - add: 'Comment archive' target: self selector: #commentArchive; - balloonTextForLastItem: 'Add a comment for the entire archive'. - - self selectedMember ifNotNil: [ :member | - menu - addLine; - add: 'Inspect member' target: self selector: #inspectMember; - balloonTextForLastItem: 'Inspect the selected member'; - add: 'Comment member' target: self selector: #commentMember; - balloonTextForLastItem: 'Add a comment for the selected member'; - addLine; - add: 'member go up in order ' target: self selector: #upMember; - add: 'member go down in order ' target: self selector: #downMember; - add: 'select member order ' target: self selector: #toIndexPlace; - addLine. - services := FileServices itemsForFile: member fileName. - menu addServices2: services for: self extraLines: #(). - ]. - - - ^menu! Item was removed: - ----- Method: ArchiveViewer>>members (in category 'accessing') ----- - members - ^archive ifNil: [ #() asOrderedCollection ] - ifNotNil: [ archive members asOrderedCollection ]! Item was removed: - ----- Method: ArchiveViewer>>openNewArchive (in category 'archive operations') ----- - openNewArchive - | result | - result := UIManager default chooseFileMatching: '*' . - result ifNil: [ ^self ]. - self fileName: result - ! Item was removed: - ----- Method: ArchiveViewer>>perform:orSendTo: (in category 'message handling') ----- - perform: selector orSendTo: otherTarget - ^ self perform: selector! Item was removed: - ----- Method: ArchiveViewer>>readOnlyStream (in category 'accessing') ----- - readOnlyStream - "Answer a read-only stream on the selected member. - For the various stream-reading services." - - ^self selectedMember ifNotNil: [ :mem | mem contentStream ascii ]! Item was removed: - ----- Method: ArchiveViewer>>renameMember (in category 'member operations') ----- - renameMember - | newName | - self canRenameMember ifFalse: [ ^self ]. - newName := UIManager default - request: 'New name for member:' - initialAnswer: self selectedMember fileName. - newName notEmpty ifTrue: [ - self selectedMember fileName: newName. - self changed: #memberList - ]! Item was removed: - ----- Method: ArchiveViewer>>saveArchive (in category 'archive operations') ----- - saveArchive - | result name | - - name := FileDirectory localNameFor: labelString . - self canSaveArchive ifFalse: [ ^self ]. - result := UIManager default - saveFilenameRequest: 'Save this zip to' - initialAnswer: name. - result ifNil: [ ^self ]. - - (archive canWriteToFileNamed: result) - ifFalse: [ self inform: name, ' is used by one or more members - in your archive, and cannot be overwritten. - Try writing to another file name'. - ^self ]. - [ archive writeToFileNamed: result ] on: Error do: [ :ex | self inform: ex description. ]. - self setLabel: name asString. - self changed: #memberList "in case CRC's and compressed sizes got set"! Item was removed: - ----- Method: ArchiveViewer>>selectedMember (in category 'accessing') ----- - selectedMember - ^memberIndex - ifNil: [ nil ] - ifNotNil: [ self members at: memberIndex ifAbsent: [ ] ]! Item was removed: - ----- Method: ArchiveViewer>>stream: (in category 'initialization') ----- - stream: aStream - archive := ZipArchive new readFrom: aStream. - self setLabel: aStream fullName. - self memberIndex: 0. - self changed: #memberList! Item was removed: - ----- Method: ArchiveViewer>>toIndexPlace (in category 'member order') ----- - toIndexPlace - | index max temp | - max := self archive members size. - index :=0. - [index := (UIManager default - request: 'To which index ' - initialAnswer: '1') asInteger. - index between: 1 and: max] whileFalse. - temp := (self archive members) at: memberIndex. - self archive members at: memberIndex put: (self archive members at: index). - self archive members at: index put: temp. - self memberIndex: 0. - self changed: #memberList.! Item was removed: - ----- Method: ArchiveViewer>>upMember (in category 'member order') ----- - upMember - | temp | - temp := (self archive members) at: memberIndex. - self archive members at: memberIndex put: (self archive members at: memberIndex -1). - self archive members at: (memberIndex -1) put: temp. - self memberIndex: 0. - self changed: #memberList.! Item was removed: - ----- Method: ArchiveViewer>>windowIsClosing (in category 'initialization') ----- - windowIsClosing - archive ifNotNil: [ archive close ].! Item was removed: - ----- Method: ArchiveViewer>>writePrependingFile (in category 'archive operations') ----- - writePrependingFile - | result name prependedName | - self canSaveArchive ifFalse: [ ^self ]. - name := FileSaverDialog openOn: FileDirectory default initialFilename: 'archive.zip' label: 'Choose location to save archive' translated. - name ifNil: [ ^self ]. - (archive canWriteToFileNamed: name) - ifFalse: [ self inform: name, ' is used by one or more members - in your archive, and cannot be overwritten. - Try writing to another file name' translated. - ^self ]. - result := FileSaverDialog openOn: FileDirectory default initialFilename: 'archive.zip' label: 'Prepended File:' translated. - result ifNil: [ ^self ]. - prependedName := result directory fullNameFor: result name. - [ archive writeToFileNamed: name prependingFileNamed: prependedName ] - on: Error - do: [ :ex | self inform: ex description. ]. - self changed: #memberList "in case CRC's and compressed sizes got set"! Item was removed: - ----- Method: ArrayedCollection>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Array'! Item was removed: - ----- Method: Bag>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ BagInspector! Item was removed: - DictionaryInspector subclass: #BagInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !BagInspector commentStamp: 'mt 4/2/2020 10:32' prior: 0! - I am an inspector for bags. I specialize the inspector for dictionaries because I expose the internal dictionary all bags use.! Item was removed: - ----- Method: BagInspector>>addElement: (in category 'menu commands') ----- - addElement: anObject - - self object add: anObject. - self updateFields. - self selectElementAt: anObject.! Item was removed: - ----- Method: BagInspector>>elementGetterAt: (in category 'private') ----- - elementGetterAt: element - "Return a way to access the number of occurrences in the bag for the given element." - - ^ [:bag | (bag instVarNamed: #contents) at: element]! Item was removed: - ----- Method: BagInspector>>elementIndices (in category 'initialization') ----- - elementIndices - - ^ [ (object instVarNamed: #contents) keysInOrder ] ifError: [ - "Can occur when debugging Bag new" - Array empty ].! Item was removed: - ----- Method: BagInspector>>elementSetterAt: (in category 'private') ----- - elementSetterAt: element - "Change the number of occurrences for the given element." - - ^ [:bag :count | (bag instVarNamed: #contents) at: element put: count]! Item was removed: - ----- Method: BagInspector>>isBindingSelected (in category 'bindings') ----- - isBindingSelected - - ^ false! Item was removed: - ----- Method: BagInspector>>removeSelectedElement (in category 'menu commands') ----- - removeSelectedElement - - self object remove: self selectedKey.! Item was removed: - Inspector subclass: #BasicInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !BasicInspector commentStamp: 'mt 3/30/2020 14:38' prior: 0! - I am an Inspector that sends as few messages as possible to collect information about the inspected object. For example, use me to inspect proxies, which are typically subclasses of ProtoObject and hence understand only little messages but make heay use of #doesNotUnderstand:.! Item was removed: - ----- Method: BasicInspector class>>openOn:withLabel: (in category 'as yet unclassified') ----- - openOn: anObject withLabel: label - "Ignore label." - - ^ ToolBuilder open: (self on: anObject)! Item was removed: - ----- Method: BasicInspector>>basicObjectPrintString (in category 'initialization') ----- - basicObjectPrintString - - ^ 'a {1}({2})' format: {thisContext objectClass: object. object identityHash}! Item was removed: - ----- Method: BasicInspector>>fieldObjectClass (in category 'fields') ----- - fieldObjectClass - - ^ (self newFieldForType: #proto key: #class) - name: 'class'; emphasizeName; - valueGetter: [:object | thisContext objectClass: object]; - valueGetterExpression: 'thisContext objectClass: self'; - yourself! Item was removed: - ----- Method: BasicInspector>>fieldObjectSize (in category 'fields') ----- - fieldObjectSize - - ^ (self newFieldForType: #proto key: #size) - name: 'size'; emphasizeName; - valueGetter: [:object | thisContext objectSize: object]; - valueGetterExpression: 'thisContext objectSize: self'; - yourself! Item was removed: - ----- Method: BasicInspector>>fieldSelf (in category 'fields') ----- - fieldSelf - - ^ (self newFieldForType: #self key: #self) - name: 'self'; emphasizeName; - valueGetter: [:obj | self basicObjectPrintString]; printValueAsIs; - valueGetterExpression: 'self'; - valueSetter: [:obj :value | self object: value]; "Switch to another object-under-inspection." - yourself! Item was removed: - ----- Method: BasicInspector>>inspect: (in category 'initialization') ----- - inspect: anObject - "We don't want to change the inspector class. Only set anObject as the inspectee." - self object: anObject! Item was removed: - ----- Method: BasicInspector>>labelString (in category 'initialization') ----- - labelString - - ^ '{1} {2}{3}' format: { - '[basic]' translated. - self basicObjectPrintString. - (self object isReadOnlyObject - ifTrue: [' (read-only)' translated] - ifFalse: [''])}! Item was removed: - ----- Method: BasicInspector>>objectOkToClose (in category 'user interface - window') ----- - objectOkToClose - "No extra interaction with the object in the basic inspector:" - - ^ true! Item was removed: - ----- Method: BasicInspector>>streamBaseFieldsOn: (in category 'fields - streaming') ----- - streamBaseFieldsOn: aStream - - aStream - nextPut: self fieldSelf; - nextPut: self fieldObjectClass; - nextPut: self fieldObjectSize.! Item was removed: - ----- Method: BasicInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') ----- - streamIndexedVariablesOn: aStream - "Truncate indexed variables if there are too many of them." - - self - streamOn: aStream - truncate: (1 to: (thisContext objectSize: self object)) - collectFields: [:index | - (self newFieldForType: #indexed key: index) - name: index asString; - valueGetter: [:object | thisContext object: object basicAt: index]; - valueGetterExpression: ('thisContext object: {1} basicAt: {2}' format: { 'self'. index }); - valueSetter: [:object :value | thisContext object: object basicAt: index put: value]; - yourself]! Item was removed: - ----- Method: BasicInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') ----- - streamInstanceVariablesOn: aStream - - | attributesForInstVars | - attributesForInstVars := (UserInterfaceTheme current get: #instVar for: #SHTextStylerST80) ifNil: [#()]. - - (thisContext objectClass: self object) allInstVarNames withIndexDo: [:name :index | - aStream nextPut: ((self newFieldForType: #instVar key: name) - name: name; styleName: attributesForInstVars; - valueGetter: [:obj | thisContext object: obj instVarAt: index]; - valueGetterExpression: ('thisContext object: {1} instVarAt: {2}' format: { 'self'. index }); - valueSetter: [:obj :value | thisContext object: obj instVarAt: index put: value]; - yourself)].! Item was removed: - ----- Method: Behavior>>browse (in category '*Tools-Browsing') ----- - browse - ^ToolSet browseClass: self! Item was removed: - ----- Method: Behavior>>createGetterFor: (in category '*Tools-Browser-accessors') ----- - createGetterFor: aName - - | code | - code := '{1}\\ ^ {1}' withCRs format: {aName}. - self compile: code classified: #accessing notifying: nil.! Item was removed: - ----- Method: Behavior>>createInstVarAccessors (in category '*Tools-Browser-accessors') ----- - createInstVarAccessors - "Create getters and setters for all inst vars defined here, - except do NOT clobber or override any selectors already understood by me" - - self instVarNames - collect: [:each | each asSymbol] - thenDo: [:instVar | - (self canUnderstand: instVar) ifFalse: [self createGetterFor: instVar]. - (self canUnderstand: instVar asSimpleSetter) ifFalse: [self createSetterFor: instVar]]. - - ! Item was removed: - ----- Method: Behavior>>createSetterFor: (in category '*Tools-Browser-accessors') ----- - createSetterFor: aName - - | code | - code := '{1}: anObject\\ {2}{1} := anObject.' withCRs - format: {aName. self settersReturnValue ifTrue: ['^ '] ifFalse: ['']}. - self compile: code classified: #accessing notifying: nil.! Item was removed: - ----- Method: Behavior>>inspectAllInstances (in category '*Tools-accessing instances and variables') ----- - inspectAllInstances - "Inpsect all instances of the receiver. 1/26/96 sw" - - | all allSize prefix | - all := self allInstances. - (allSize := all size) = 0 ifTrue: [^ self inform: 'There are no - instances of ', self name]. - prefix := allSize = 1 - ifTrue: ['The lone instance'] - ifFalse: ['The ', allSize printString, ' instances']. - - all asArray inspectWithLabel: (prefix, ' of ', self name)! Item was removed: - ----- Method: Behavior>>inspectSubInstances (in category '*Tools-accessing instances and variables') ----- - inspectSubInstances - "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" - - | all allSize prefix | - all := self allSubInstances. - (allSize := all size) = 0 ifTrue: [^ self inform: 'There are no - instances of ', self name, ' - or any of its subclasses']. - prefix := allSize = 1 - ifTrue: ['The lone instance'] - ifFalse: ['The ', allSize printString, ' instances']. - - all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! Item was removed: - ----- Method: Behavior>>settersReturnValue (in category '*Tools-Browser-accessors') ----- - settersReturnValue - "Determine whether the browser's createInstVarAccessors code will generate - setters that answer self (the default here) or the value set. Classes that want - to answer the value set (e.g. VMStructType) override." - - ^ false! Item was removed: - ----- Method: Behavior>>toolIcon (in category '*Tools-icons') ----- - toolIcon - "Tools can annotate me with an icon identified by the symbol this method returns. - Defaults to no icon" - ^ #blank! Item was removed: - ----- Method: Behavior>>toolIconSelector: (in category '*Tools-icons') ----- - toolIconSelector: aSymbol - "Tools can annotate the method identified by aSymbol with an icon identified by the symbol this method returns. - We customize this for, eg, overriden methods or methods with breaks. - Defaults to no icon" - - self methodDictionary at: aSymbol ifPresent: [ :method | - method hasBreakpoint ifTrue: [^ #breakpoint]. - method selectorsDo: [:messageSelector | - (#(halt halt: haltIfNil haltIf: haltOnce haltOnce: haltOnCount: halt:onCount: break) includes: messageSelector) - ifTrue: [^ #breakpoint]. - (#(flag: needsWork notYetImplemented) includes: messageSelector) - ifTrue: [^ #flag]. - (#(shouldBeImplemented subclassResponsibility) includes: messageSelector) - ifTrue: [ - (self isSelectorOverridden: aSymbol) - ifTrue: [^ #abstract] - ifFalse: [^ #notOverridden]]. - messageSelector == #shouldNotImplement - ifTrue: [^ #no]]. - method hasReportableSlip ifTrue: [^ #breakpoint]]. - - (self isSelectorOverride: aSymbol) - ifTrue: [ - (self isSelectorOverridden: aSymbol) - ifTrue: [ ^ #arrowUpAndDown ] - ifFalse: [ ^ #arrowUp ] ] - ifFalse: [ - (self isSelectorOverridden: aSymbol) - ifTrue: [^ #arrowDown ]]. - - self methodDictionary at: aSymbol ifPresent: [ :method | - (method primitive ~= 0 and: [method isQuick not]) - ifTrue: [^ #primitive]]. - - - ^ #blank! Item was removed: - ----- Method: Bitset>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ BitsetInspector! Item was removed: - CollectionInspector subclass: #BitsetInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !BitsetInspector commentStamp: 'mt 4/22/2020 08:13' prior: 0! - I am an inspector for bit sets. I display bits with zero based indexing corresponding to the bit numbering conventions of a bit field.! Item was removed: - ----- Method: BitsetInspector>>addElement: (in category 'menu - commands') ----- - addElement: anInteger - "Flip the specified bit to 1 and select it. Note that there is no need to #updateFields here because of the bitset's semantics for #add:." - - self object add: anInteger. - self selectElementAt: anInteger.! Item was removed: - ----- Method: BitsetInspector>>elementIndices (in category 'private') ----- - elementIndices - - ^ 0 to: self objectSize - 1! Item was removed: - ----- Method: BitsetInspector>>fieldSize (in category 'fields') ----- - fieldSize - - ^ (self newFieldForType: #misc key: #size) - name: 'num 1 bits' translated; emphasizeName; - valueGetter: [:bitset | bitset size]; - yourself! Item was removed: - ----- Method: BitsetInspector>>objectSize (in category 'private') ----- - objectSize - - ^ self object capacity! Item was removed: - ----- Method: BitsetInspector>>removeSelectedElement (in category 'menu - commands') ----- - removeSelectedElement - "Flip the selected bit back to 0." - - self selectedField setValueFor: self to: 0.! Item was removed: - ----- Method: BitsetInspector>>streamBaseFieldsOn: (in category 'fields - streaming') ----- - streamBaseFieldsOn: aStream - - super streamBaseFieldsOn: aStream. - aStream nextPut: self fieldSize.! Item was removed: - ----- Method: BlockClosure>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ BlockClosureInspector! Item was removed: - ----- Method: BlockClosure>>timeProfile (in category '*Tools') ----- - timeProfile - - ^TimeProfileBrowser onBlock: self! Item was removed: - Inspector subclass: #BlockClosureInspector - instanceVariableNames: 'debuggerMap tempVarNames instVarNames' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! Item was removed: - ----- Method: BlockClosureInspector>>bindingOf: (in category 'evaluation') ----- - bindingOf: aString - " See commentary in #doItReceiver. Yes, we cannot evalute the closured bindings by name in the code pane. But we can browse and change the bindings through their inspector fields. - - self object method literalsDo: [:literal | - (literal isVariableBinding and: [literal key = aString]) - ifTrue: [^ literal]]. - " - - ^ super bindingOf: aString! Item was removed: - ----- Method: BlockClosureInspector>>debuggerMap (in category 'private') ----- - debuggerMap - - ^ debuggerMap ifNil: [debuggerMap := self object method debuggerMap]! Item was removed: - ----- Method: BlockClosureInspector>>doItReceiver (in category 'evaluation') ----- - doItReceiver - "Overwritten for documentation only. We cannot expose the closured 'self' here because users expect the closure to be the #doItReceiver so that 'self value' can be used to evaluate the block. We can, however, configure the styler to at least style #fieldSource correctly. See #updateStyler:requestor: and #hasBindingOf:. - - Note that you can always debug-it the expression 'self value' to the evaluate parts of the closure." - - ^ super doItReceiver! Item was removed: - ----- Method: BlockClosureInspector>>fieldSource (in category 'fields') ----- - fieldSource - - ^ (self newFieldForType: #code key: #source) - name: 'source code' translated; emphasizeName; - valueGetter: [:blockClosure | '"{1}"\{2}' withCRs format: {blockClosure outerContext. blockClosure decompile decompileString}]; printValueAsIs; - shouldStyleValue: true; - yourself! Item was removed: - ----- Method: BlockClosureInspector>>hasBindingOf: (in category 'user interface - styling') ----- - hasBindingOf: aString - - self object method literalsDo: [:literal | - (literal isVariableBinding and: [literal key = aString]) - ifTrue: [^ true]]. - - (self tempVarNames includes: aString) ifTrue: [^ true]. - (self instVarNames includes: aString) ifTrue: [^ true]. - - ^ false! Item was removed: - ----- Method: BlockClosureInspector>>instVarNames (in category 'private') ----- - instVarNames - - ^ instVarNames ifNil: [instVarNames := (self object receiver perform: #class "avoid inlining; support proxies") allInstVarNames]! Item was removed: - ----- Method: BlockClosureInspector>>replaceSelectionValue: (in category 'selection') ----- - replaceSelectionValue: anObject - - | success | - (success := super replaceSelectionValue: anObject) ifTrue: [ - self selectedField key = #receiver - ifTrue: [instVarNames := nil]]. - ^ success! Item was removed: - ----- Method: BlockClosureInspector>>streamBaseFieldsOn: (in category 'fields - streaming') ----- - streamBaseFieldsOn: aStream - - super streamBaseFieldsOn: aStream. - aStream nextPut: self fieldSource.! Item was removed: - ----- Method: BlockClosureInspector>>streamBindingsOn: (in category 'fields - streaming') ----- - streamBindingsOn: aStream - - | compiledCode instNames tempNames | - self flag: #decompile. "mt: Use #to: and #do: instead of #to:do: to avoid inlining to preserve bindings in enumeration block for later decompilation. See InspectorField." - - (1 to: (instNames := self instVarNames) size) do: [:index | - aStream nextPut: ((self newFieldForType: #instVar key: index) - name: ('[[[{1}]]]' format: {instNames at: index}); - valueGetter: [:closure | closure receiver instVarAt: index]; - valueSetter: [:closure :value | closure receiver instVarAt: index put: value]; - yourself)]. - - tempNames := self tempVarNames. - "No need to show closured bindings from outerContext. The important temps are already covered in the indexed fields below." - (1 to: tempNames size - self object basicSize) do: [:index | - aStream nextPut: ((self newFieldForType: #tempVar key: index) - name: ('[[{1}]]' format: {tempNames at: index}); - valueGetter: [:closure | closure outerContext tempAt: index]; - valueSetter: [:closure :value | closure outerContext tempAt: index put: value]; - yourself)]. - - (1 to: (compiledCode := self object method) numLiterals) do: [:index | - | literal | - literal := compiledCode literalAt: index. - literal isVariableBinding ifTrue: [ - aStream nextPut: ((self newFieldForType: #tempVar key: index) - name: ('[{1}]' format: {literal key}); - valueGetter: [:closure | (closure method literalAt: index) value]; - valueSetter: [:closure :value | (closure method literalAt: index) value: value]; - yourself)]]. - - (1 to: self object basicSize) do: [:index | - aStream nextPut: ((self newFieldForType: #tempVar key: index) - name: ('[{1}]' format: {tempNames at: index + tempNames size - self object basicSize}); - valueGetter: [:closure | closure basicAt: index]; - valueSetter: [:closure :value | closure basicAt: index put: value]; - yourself)]. - - - "See commentary in #doItReceiver. No need to expose the closured 'self' here because there is already the #receiver instVar. - - fieldReceiver - ^ (self newFieldForType: #tempVar key: #receiver) - name: '[self]'; - valueGetter: [:obj | obj receiver]; - valueSetter: [:obj :value | obj receiver: value]; - yourself - "! Item was removed: - ----- Method: BlockClosureInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') ----- - streamInstanceVariablesOn: aStream - "Add (closured) bindings to the list." - - super streamInstanceVariablesOn: aStream. - self streamBindingsOn: aStream.! Item was removed: - ----- Method: BlockClosureInspector>>tempVarNames (in category 'private') ----- - tempVarNames - - ^ tempVarNames ifNil: [tempVarNames := self debuggerMap tempNamesForContext: self object outerContext]! Item was removed: - ----- Method: BlockClosureInspector>>updateStyler:requestor: (in category 'user interface - styling') ----- - updateStyler: aStyler requestor: anObject - "Overwritten to let the receiver behave like a Workspace to be asked for #hasBindingOf:." - - super updateStyler: aStyler requestor: anObject. - aStyler workspace: self.! Item was removed: - ----- Method: Boolean>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Boolean'! Item was removed: - CodeHolder subclass: #Browser - instanceVariableNames: 'environment systemOrganizer classOrganizer metaClassOrganizer editSelection metaClassIndicated selectedSystemCategory selectedClassName selectedMessageName selectedMessageCategoryName classDefinition metaClassDefinition' - classVariableNames: 'ListClassesHierarchically RecentClasses ShowClassIcons ShowMessageIcons SortMessageCategoriesAlphabetically' - poolDictionaries: '' - category: 'Tools-Browser'! - - !Browser commentStamp: 'cwp 12/27/2012 11:09' prior: 0! - I represent a query path into the class descriptions, the software of the system.! Item was removed: - ----- Method: Browser class>>canUseMultiWindowBrowsers (in category 'preferences') ----- - canUseMultiWindowBrowsers - ^true! Item was removed: - ----- Method: Browser class>>cleanUp (in category 'class initialization') ----- - cleanUp - "Flush caches" - - self initialize.! Item was removed: - ----- Method: Browser class>>fullOnCategory: (in category 'instance creation') ----- - fullOnCategory: aCategory - "Open a new full browser set to the system category." - - ^ self new - selectSystemCategory: aCategory asSymbol; - buildAndOpenFullBrowser! Item was removed: - ----- Method: Browser class>>fullOnClass: (in category 'instance creation') ----- - fullOnClass: aClass - "Open a new full browser set to class." - "Browser fullOnClass: Browser" - - ^ self new - setClass: aClass; - buildAndOpenFullBrowser! Item was removed: - ----- Method: Browser class>>fullOnClass:category: (in category 'instance creation') ----- - fullOnClass: aClass category: category - "Open a new full browser set to class and message category." - "Browser fullOnClass: Browser category: 'controls' " - - ^ self new - setClass: aClass; - selectMessageCategoryNamed: category; - buildAndOpenFullBrowser! Item was removed: - ----- Method: Browser class>>fullOnClass:selector: (in category 'instance creation') ----- - fullOnClass: aClass selector: aSelector - "Open a new full browser set to the class and selector." - "Browser fullOnClass: Browser selector: #defaultWindowColor" - - ^ self new - setClass: aClass selector: aSelector; - buildAndOpenFullBrowser! Item was removed: - ----- Method: Browser class>>fullOnClassComment: (in category 'instance creation') ----- - fullOnClassComment: aClass - - ^ self new - setClass: aClass; - editComment; - buildAndOpenFullBrowser! Item was removed: - ----- Method: Browser class>>fullOnEnvironment: (in category 'instance creation') ----- - fullOnEnvironment: anEnvironment - - ^ self new - selectEnvironment: anEnvironment; - buildAndOpenFullBrowser! Item was removed: - ----- Method: Browser class>>initialize (in category 'class initialization') ----- - initialize - "Browser initialize" - - RecentClasses := OrderedCollection new. - self - registerInFlapsRegistry; - registerInAppRegistry ! Item was removed: - ----- Method: Browser class>>listClassesHierarchically (in category 'preferences') ----- - listClassesHierarchically - <preference: 'List classes hierarchically' - category: 'browsing' - description: 'When enabled, the class list in the browser is arranged and indented with regard to the class hierarchy.' - type: #Boolean> - ^ListClassesHierarchically ifNil: [false] - ! Item was removed: - ----- Method: Browser class>>listClassesHierarchically: (in category 'preferences') ----- - listClassesHierarchically: aBool - - ListClassesHierarchically := aBool! Item was removed: - ----- Method: Browser class>>new (in category 'instance creation') ----- - new - - ^super new systemOrganizer: SystemOrganization! Item was removed: - ----- Method: Browser class>>newOnCategory: (in category 'instance creation') ----- - newOnCategory: aCategory - "Open a new browser on this category" - - "Browser newOnCategory: 'Tools-Browser'" - - ^self newOnCategory: aCategory label: 'Classes in category ', aCategory - ! Item was removed: - ----- Method: Browser class>>newOnCategory:editString:label: (in category 'instance creation') ----- - newOnCategory: aCategory editString: aString label: aLabel - "Open a new browser on this category (testing first for existence) with aString pre-selected in the code pane. - We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened" - - "Browser newOnCategory: 'Tools-Browser' editString: 'test string edit setup' label: 'Testing category browser with set edit string'" - - | newBrowser | - newBrowser := self newOnCategory: aCategory label: aLabel. - aString ifNotNil:[newBrowser changed: #editString with: aString]. - ^ newBrowser - - ! Item was removed: - ----- Method: Browser class>>newOnCategory:label: (in category 'instance creation') ----- - newOnCategory: aCategory label: aLabel - "Open a new browser on this category (testing first for existence)." - - "Browser newOnCategory: 'Tools-Browser' label: 'Testing category browser'" - - | newBrowser newCat | - newBrowser := self new. - newCat := aCategory asSymbol. - (newBrowser systemCategoryList includes: newCat) - ifTrue: [ newBrowser selectSystemCategory: newCat ] - ifFalse: [ ^ self inform: 'No such category' ]. - - newBrowser buildAndOpenCategoryBrowserLabel: aLabel. - ^ newBrowser - - ! Item was removed: - ----- Method: Browser class>>newOnClass: (in category 'instance creation') ----- - newOnClass: aClass - "Open a new class browser on this class." - ^ self newOnClass: aClass label: 'Class Browser: ', aClass name! Item was removed: - ----- Method: Browser class>>newOnClass:editString:label: (in category 'instance creation') ----- - newOnClass: aClass editString: aString label: aLabel - "Open a new class browser on this class with aString pre-selected in the code pane. - We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened" - "Browser newOnClass: Browser editString: 'test string edit setup' label: 'Testing category browser with set edit string'" - | newBrowser| - - newBrowser := self newOnClass: aClass label: aLabel. - newBrowser editSelection: #newMessage. - aString ifNotNil:[newBrowser changed: #editString with: aString]. - ^ newBrowser - ! Item was removed: - ----- Method: Browser class>>newOnClass:label: (in category 'instance creation') ----- - newOnClass: aClass label: aLabel - "Open a new class browser on this class and set the label." - "Browser newOnClass: Browser label: 'A specific label that I want'" - | newBrowser | - - newBrowser := self new. - newBrowser setClass: aClass. - ^ newBrowser buildAndOpenClassBrowserLabel: aLabel - ! Item was removed: - ----- Method: Browser class>>newOnClass:messageCategory: (in category 'instance creation') ----- - newOnClass: aClass messageCategory: aCategory - - ^ self newOnClass: aClass messageCategory: aCategory editString: nil label: 'Message Category Browser (' , aClass name, ')'.! Item was removed: - ----- Method: Browser class>>newOnClass:messageCategory:editString:label: (in category 'instance creation') ----- - newOnClass: aClass messageCategory: aCategory editString: aString label: aLabel - "Open a new message protocol browser on this class & protocol with aString pre-selected in the code pane. - We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened" - - ^self newOnClass: aClass messageCategory: aCategory selector: nil editString: aString label: aLabel! Item was removed: - ----- Method: Browser class>>newOnClass:messageCategory:selector:editString:label: (in category 'instance creation') ----- - newOnClass: aClass messageCategory: aCategory selector: aSelector editString: aString label: aLabel - "Open a new message protocol browser on this class & protocol with aString pre-selected in the code pane. - We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened" - "Browser newOnClass: Browser messageCategory: 'controls' selector: #decorateButtons editString: 'test string edit setup' label: 'Testing class browser with set edit string'" - | newBrowser| - - newBrowser := self new. - "setting up a new browser for a specific class, category and selector requires this order of messages - since the #selectMessageCategoryNamed: carefully nils the chosen selector; thus we can't use - the more obvious seeming #setClass:selector: method" - newBrowser - setClass: aClass; - selectMessageCategoryNamed: aCategory; - selectMessageNamed: aSelector; - editSelection: #editMessage. - - newBrowser buildAndOpenMessageCategoryBrowserLabel: 'Message Category Browser (' , aClass name, ')'. - aString ifNotNil:[newBrowser changed: #editString with: aString]. - ^newBrowser! Item was removed: - ----- Method: Browser class>>newOnClass:selector: (in category 'instance creation') ----- - newOnClass: aClass selector: aSymbol - "Open a new class browser on this class." - "Browser newOnClass: Browser selector: #decorateButtons" - | newBrowser | - - newBrowser := self new. - newBrowser setClass: aClass selector: aSymbol. - ^ newBrowser buildAndOpenClassBrowserLabel: 'Class Browser: ', aClass name - ! Item was removed: - ----- Method: Browser class>>open (in category 'instance creation') ----- - open - ^self openBrowser - - ! Item was removed: - ----- Method: Browser class>>openBrowser (in category 'instance creation') ----- - openBrowser - "Open a standard system browser with the generic category/class/protocol/message lists" - "Browser openBrowser" - - ^ self new buildAndOpenFullBrowser - - ! Item was removed: - ----- Method: Browser class>>prototypicalToolWindow (in category 'instance creation') ----- - prototypicalToolWindow - "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" - - ^ ToolBuilder default build: self ! Item was removed: - ----- Method: Browser class>>registerInAppRegistry (in category 'class initialization') ----- - registerInAppRegistry - "Register the receiver in the SystemBrowser AppRegistry" - SystemBrowser register: self.! Item was removed: - ----- Method: Browser class>>registerInFlapsRegistry (in category 'class initialization') ----- - registerInFlapsRegistry - "Register the receiver in the system's flaps registry" - self environment - at: #Flaps - ifPresent: [:cl | cl registerQuad: {#Browser. #prototypicalToolWindow. 'Browser' translatedNoop. 'A Browser is a tool that allows you to view all the code of all the classes in the system' translatedNoop} - forFlapNamed: 'Tools']! Item was removed: - ----- Method: Browser class>>showClassIcons (in category 'preferences') ----- - showClassIcons - <preference: 'Show class icons' - category: 'browsing' - description: 'When enabled, the class list will show icons for some standard types such as Morph and Magnitude.' - type: #Boolean> - ^ShowClassIcons ifNil: [true] - ! Item was removed: - ----- Method: Browser class>>showClassIcons: (in category 'preferences') ----- - showClassIcons: aBoolean - ShowClassIcons := aBoolean.! Item was removed: - ----- Method: Browser class>>showMessageIcons (in category 'preferences') ----- - showMessageIcons - <preference: 'Show message icons' - category: 'browsing' - description: 'When enabled, the message list will show icons for flags, overrides, etc.' - type: #Boolean> - ^ShowMessageIcons ifNil: [true] - ! Item was removed: - ----- Method: Browser class>>showMessageIcons: (in category 'preferences') ----- - showMessageIcons: aBoolean - - ShowMessageIcons := aBoolean.! Item was removed: - ----- Method: Browser class>>sortMessageCategoriesAlphabetically (in category 'preferences') ----- - sortMessageCategoriesAlphabetically - - <preference: 'Sort Message Categories Alphabetically' - categoryList: #(browsing Tools) - description: 'When enabled, the message category list in the browser is ordered by alphabet. No need to ''alphabetize'' this list manually via the context menu.' - type: #Boolean> - - ^ SortMessageCategoriesAlphabetically ifNil: [false] - ! Item was removed: - ----- Method: Browser class>>sortMessageCategoriesAlphabetically: (in category 'preferences') ----- - sortMessageCategoriesAlphabetically: aBoolean - - SortMessageCategoriesAlphabetically := aBoolean. - ! Item was removed: - ----- Method: Browser class>>systemOrganizer: (in category 'instance creation') ----- - systemOrganizer: anOrganizer - - ^(super new) - systemOrganizer: anOrganizer; - yourself! Item was removed: - ----- Method: Browser class>>unload (in category 'class initialization') ----- - unload - "Unload the receiver from global registries" - - self environment at: #Flaps ifPresent: [:cl | - cl unregisterQuadsWithReceiver: self]. - SystemBrowser unregister: self.! Item was removed: - ----- Method: Browser>>aboutToStyle: (in category 'code pane') ----- - aboutToStyle: aStyler - "This is a notification that aStyler is about to re-style its text. - Set the classOrMetaClass in aStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - | type | - - self isModeStyleable ifFalse: [^false]. - type := self editSelection. - (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false]. - aStyler classOrMetaClass: ((type = #editClass or: [type = #newClass]) ifFalse:[self selectedClassOrMetaClass]). - ^true! Item was removed: - ----- Method: Browser>>addAllMethodsToCurrentChangeSet (in category 'class functions') ----- - addAllMethodsToCurrentChangeSet - "Add all the methods in the selected class or metaclass to the current change set. You ought to know what you're doing before you invoke this!!" - - | aClass | - (aClass := self selectedClassOrMetaClass) ifNotNil: - [aClass selectorsDo: - [:sel | - ChangeSet current adoptSelector: sel forClass: aClass]. - self changed: #annotation] - ! Item was removed: - ----- Method: Browser>>addCategory (in category 'message category functions') ----- - 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 newName oldCategory | - self okToChange ifFalse: [^ self]. - self hasClassSelected ifFalse: [^ self]. - labels := OrderedCollection new. - reject := Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines := OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats := cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats sort. - reject addAll: cats]]]. - (newName := UIManager default - chooseFromOrAddTo: labels - lines: lines - title: 'Add Category') ifNil: [^ self]. - newName isEmpty - ifTrue: [^ self] - ifFalse: [newName := newName asSymbol]. - oldCategory := self selectedMessageCategoryName. - self classOrMetaClassOrganizer - addCategory: newName - before: (self hasMessageCategorySelected - ifFalse: [nil] - ifTrue: [self selectedMessageCategoryName]). - self changed: #messageCategoryList. - self selectMessageCategoryNamed: newName. - self changed: #messageCategoryList. - ! Item was removed: - ----- Method: Browser>>addExtraShiftedItemsTo: (in category 'message list') ----- - addExtraShiftedItemsTo: aMenu - "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples." - ! Item was removed: - ----- Method: Browser>>addModelItemsToWindowMenu: (in category 'user interface') ----- - addModelItemsToWindowMenu: aMenu - "Add model-related items to the window menu" - super addModelItemsToWindowMenu: aMenu. - SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self.! Item was removed: - ----- Method: Browser>>addSpecialMenu: (in category 'traits') ----- - addSpecialMenu: aMenu - aMenu addList: #( - - - ('new class' newClass) - ('new trait' newTrait) - -). - self selectedClass notNil ifTrue: [ - aMenu addList: #( - ('add trait' addTrait) - -) ]. - aMenu addList: #(-). - ^ aMenu! Item was removed: - ----- Method: Browser>>addSystemCategory (in category 'system category functions') ----- - addSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - | oldSelection newName | - self okToChange ifFalse: [^ self]. - oldSelection := self selectedSystemCategory. - newName := self - request: 'Please type new category name' - initialAnswer: 'Category-Name'. - newName isEmpty - ifTrue: [^ self] - ifFalse: [newName := newName asSymbol]. - systemOrganizer - addCategory: newName - before: self selectedSystemCategory. - self selectSystemCategory: - (oldSelection isNil - ifTrue: [ self systemCategoryList last ] - ifFalse: [ oldSelection ]). - self changed: #systemCategoryList.! Item was removed: - ----- Method: Browser>>addTrait (in category 'traits') ----- - addTrait - | input trait | - input := UIManager default request: 'add trait'. - input isEmptyOrNil ifFalse: [ - trait := self environment classNamed: input. - (trait isNil or: [trait isTrait not]) ifTrue: [ - ^self inform: 'Input invalid. ' , input , ' does not exist or is not a trait']. - self selectedClass setTraitComposition: self selectedClass traitComposition asTraitComposition + trait. - self contentsChanged]. - ! Item was removed: - ----- Method: Browser>>alphabetizeMessageCategories (in category 'message category functions') ----- - alphabetizeMessageCategories - | oldMessageCategory oldMethod | - oldMessageCategory := selectedMessageCategoryName. - oldMethod := selectedMessageName. - self hasClassSelected ifFalse: [^ false]. - self okToChange ifFalse: [^ false]. - self classOrMetaClassOrganizer sortCategories. - self clearUserEditFlag. - self editClass. - self selectClassNamed: selectedClassName. - self selectMessageCategoryNamed: oldMessageCategory. - self selectMessageNamed: oldMethod. - ^ true! Item was removed: - ----- Method: Browser>>alphabetizeSystemCategories (in category 'system category functions') ----- - alphabetizeSystemCategories - - self okToChange ifFalse: [^ false]. - systemOrganizer sortCategories. - self selectSystemCategory: nil. - self changed: #systemCategoryList. - ! Item was removed: - ----- Method: Browser>>annotation (in category 'annotation') ----- - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - (aClass := self selectedClassOrMetaClass) == nil ifTrue: [^ '']. - self editSelection == #editComment ifTrue: - [^ self annotationForSelector: #Comment ofClass: aClass]. - - self editSelection == #editClass ifTrue: - [^ self annotationForSelector: #Definition ofClass: aClass]. - (aSelector := self selectedMessageName) ifNil: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! Item was removed: - ----- Method: Browser>>annotation: (in category 'annotation') ----- - annotation: aText - "The user accepted aText in our annotation pane" - | theClass | - (theClass := self selectedClass) ifNil: [^false]. - self editSelection == #editClass - ifTrue: [ - self stripNaggingAttributeFromComment: aText. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - ^ false - ! Item was removed: - ----- Method: Browser>>annotationForClassCommentFor: (in category 'class comment pane') ----- - annotationForClassCommentFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class comment of the given class." - | aStamp | - aStamp := classOrganizer commentStamp. - ^ aStamp - ifNil: - [self selectedClassName, ' has no class comment'] - ifNotNil: - ['class comment for ', self selectedClassName, - (aStamp = '<historical>' - ifFalse: - [' - ', aStamp] - ifTrue: - [''])]! Item was removed: - ----- Method: Browser>>annotationForClassDefinitionFor: (in category 'class comment pane') ----- - annotationForClassDefinitionFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - ^self classCommentText! Item was removed: - ----- Method: Browser>>arrowKey:from: (in category 'multi-window support') ----- - arrowKey: aChar from: view - "Intercept Apple-Digit to select panes" - | index | - (aChar isDigit - and: [self multiWindowState notNil]) ifTrue: - [index := aChar asciiValue - $0 asciiValue. - index = 0 ifTrue: [index := 10]. - ^index <= self multiWindowState models size - ifTrue: [self multiWindowState selectWindowIndex: index] - ifFalse: [self changed: #flash]]. - ^super arrowKey: aChar from: view - ! Item was removed: - ----- Method: Browser>>browseAllClasses (in category 'system category functions') ----- - browseAllClasses - "Create and schedule a new browser on all classes alphabetically." - - ^ClassListBrowser newOnAllClasses! Item was removed: - ----- Method: Browser>>browseAllCommentsForClass (in category 'message functions') ----- - browseAllCommentsForClass - "Opens a HelpBrowser on the class" - - | myClass | - myClass := self selectedClass ifNil: [ ^self ]. - myClass isTrait ifTrue: [ ^self ]. - myClass openHelpBrowser model showTopicNamed: myClass name.! Item was removed: - ----- Method: Browser>>browseClassHierarchy (in category 'multi-window support') ----- - browseClassHierarchy - "Overridden to consider multi-window state and hierarchy browser." - - | behavior newBrowser | - (behavior := self selectedClassOrMetaClass) isNil ifTrue: - [^self]. - - (self isPackage "PackageBrowser panes can't support a hierarchy browser; not sure why." - or: [self multiWindowState isNil]) ifTrue: - [^super browseClassHierarchy]. - - newBrowser := HierarchyBrowser new - setClass: behavior; - selectMessageCategoryNamed: self selectedMessageCategoryName; - selectMessageNamed: self selectedMessageName; - editSelection: editSelection; - yourself. - - self multiWindowState addWindow: newBrowser! Item was removed: - ----- Method: Browser>>browsePackage (in category 'system category functions') ----- - browsePackage - - ^ self selectedPackage - ifNil: [self informUnknownPackage] - ifNotNil: [:package | package browse].! Item was removed: - ----- Method: Browser>>browsePackageDependencies (in category 'system category functions') ----- - browsePackageDependencies - - ^ self selectedPackage - ifNil: [self informUnknownPackage] - ifNotNil: [:package | DependencyBrowser openOnPackage: package].! Item was removed: - ----- Method: Browser>>browsePackageDependenciesInverted (in category 'system category functions') ----- - browsePackageDependenciesInverted - - ^ self selectedPackage - ifNil: [self informUnknownPackage] - ifNotNil: [:package | DependencyBrowser openInvertedOnPackage: package].! Item was removed: - ----- Method: Browser>>browsePackageExtensions (in category 'system category functions') ----- - browsePackageExtensions - - ^ self selectedPackage - ifNil: [self informUnknownPackage] - ifNotNil: [:package | self systemNavigation browseAllExtensionMethodsOfPackage: package]! Item was removed: - ----- Method: Browser>>browsePackageExtensionsLocalTo (in category 'system category functions') ----- - browsePackageExtensionsLocalTo - - ^ self selectedPackage - ifNil: [self informUnknownPackage] - ifNotNil: [:package | - self systemNavigation - browseAllExtensionMethodsOfPackage: package - localTo: self selectedSystemCategory].! Item was removed: - ----- Method: Browser>>buildAndOpenCategoryBrowser (in category 'toolbuilder') ----- - buildAndOpenCategoryBrowser - "assemble the spec for a system category browser, build it and open it - use the default label" - - ^self buildAndOpenCategoryBrowserLabel: nil - ! Item was removed: - ----- Method: Browser>>buildAndOpenCategoryBrowserLabel: (in category 'toolbuilder') ----- - buildAndOpenCategoryBrowserLabel: aLabelString - "assemble the spec for a system category browser, build it and open it" - - | builder windowSpec | - builder := ToolBuilder default. - - windowSpec := self buildCategoryBrowserWith: builder. - aLabelString ifNotNil:[:str| windowSpec label: str]. - - builder open: windowSpec. - - ^self - ! Item was removed: - ----- Method: Browser>>buildAndOpenClassBrowserLabel: (in category 'toolbuilder') ----- - buildAndOpenClassBrowserLabel: aLabelString - "assemble the spec for a class browser, build it and open it" - - | builder max windowSpec catPaneHeight| - builder := ToolBuilder default. - catPaneHeight := builder listHeight. - max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4]. - - windowSpec :=self buildWindowWith: builder specs: { - (self topConstantHeightFrame: catPaneHeight fromLeft: 0 width: 0.5) -> [self buildClassListSingletonWith: builder]. - (self frameOffsetFromTop: catPaneHeight fromLeft: 0 width: 0.5 bottomFraction: max) -> [self buildMessageCategoryListWith: builder]. - (self topConstantHeightFrame: catPaneHeight fromLeft: 0.5 width: 0.5) -> [self buildSwitchesWith: builder]. - (self frameOffsetFromTop: catPaneHeight fromLeft: 0.5 width: 0.5 bottomFraction: max) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - self setMultiWindowFor:windowSpec. - windowSpec label: aLabelString. - - builder open: windowSpec. - - ^self - ! Item was removed: - ----- Method: Browser>>buildAndOpenFullBrowser (in category 'toolbuilder') ----- - buildAndOpenFullBrowser - "assemble the spec for a full system browser, build it and open it" - - | builder window | - builder := ToolBuilder default. - - "the build-but-don't-open phase is factored out to support the prototypicalToolWindow facility" - window := self buildDefaultBrowserWith: builder. - builder open: window.! Item was removed: - ----- Method: Browser>>buildAndOpenMessageCategoryBrowserLabel: (in category 'toolbuilder') ----- - buildAndOpenMessageCategoryBrowserLabel: aLabelString - "assemble the spec for a messasge category browser, build it and open it" - - | builder max windowSpec catPaneHeight | - builder := ToolBuilder default. - catPaneHeight := builder listHeight. - max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4]. - - windowSpec :=self buildWindowWith: builder specs: { - (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0) offsets: (0 at 0 corner: 0 at catPaneHeight)) -> [self buildMessageListCatSingletonWith: builder]. - (LayoutFrame fractions: (0.0 at 0.0 corner: 1.0 at max) offsets: (0@ catPaneHeight corner: 0 at 0)) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - self setMultiWindowFor:windowSpec. - windowSpec label: aLabelString. - - builder open: windowSpec. - - ^self - ! Item was removed: - ----- Method: Browser>>buildCategoryBrowserWith: (in category 'toolbuilder') ----- - buildCategoryBrowserWith: builder - "assemble the spec for a system category browser, build it and return it" - - | max windowSpec catPaneHeight| - catPaneHeight := builder listHeight. - max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4]. - - windowSpec := self buildWindowWith: builder specs: { - (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0) offsets: (0 at 0 corner: 0 at catPaneHeight)) -> [self buildSystemCatListSingletonWith: builder]. - ((self classListFrame: max fromTop: 0 fromLeft: 0 width: 0.333) - topOffset: catPaneHeight) -> [self buildClassListWith: builder]. - (self switchesFrame: max fromLeft: 0 width: 0.333) -> [self buildSwitchesWith: builder]. - (LayoutFrame fractions: (0.333 at 0 corner: 0.666 at max) offsets: (0 at catPaneHeight corner: 0 at 0)) -> [self buildMessageCategoryListWith: builder]. - (LayoutFrame fractions: (0.666 at 0 corner: 1 at max) offsets: (0 at catPaneHeight corner: 0 at 0)) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - self setMultiWindowFor:windowSpec. - - ^builder build: windowSpec - ! Item was removed: - ----- Method: Browser>>buildClassListSingletonWith: (in category 'toolbuilder') ----- - buildClassListSingletonWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #classListSingleton; - getIndex: #indexIsOne; - setIndex: #indexIsOne:; - menu: #classListMenu:shifted:; - keyPress: #classListKey:from:; - hScrollBarPolicy: #never; - vScrollBarPolicy: #never; - minimumHeight: 0. - ^listSpec - ! Item was removed: - ----- Method: Browser>>buildClassListWith: (in category 'toolbuilder') ----- - buildClassListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #classList; - list: #classList; - getIndex: #classListIndex; - setIndex: #classListIndex:; - icon: #classIconAt:; - menu: #classListMenu:shifted:; - keyPress: #classListKey:from:. - SystemBrowser browseWithDragNDrop ifTrue: [ - listSpec - dragItem: #dragFromClassList:; - dragType: #dragTypeForClassListAt:]. - - ^listSpec - ! Item was removed: - ----- Method: Browser>>buildDefaultBrowserWith: (in category 'toolbuilder') ----- - buildDefaultBrowserWith: builder - "assemble the spec for a full system browser, build it and return the built but not opened morph" - "this build-but-don't-open phase is factored out to support the prototypicalToolWindow facility" - - | max windowSpec | - max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5]. - - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 0.25 at max) -> [self buildSystemCategoryListWith: builder]. - (self classListFrame: max) -> [self buildClassListWith: builder]. - (self switchesFrame: max) -> [self buildSwitchesWith: builder]. - (0.5 at 0 corner: 0.75 at max) -> [self buildMessageCategoryListWith: builder]. - (0.75 at 0 corner: 1 at max) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - self setMultiWindowFor:windowSpec. - windowSpec defaultFocus: #systemCategoryList. - - ^builder build: windowSpec! Item was removed: - ----- Method: Browser>>buildMessageCategoryBrowser (in category 'message category functions') ----- - buildMessageCategoryBrowser - "Create and schedule a message category browser for the currently - selected message category." - - self buildMessageCategoryBrowserEditString: nil! Item was removed: - ----- Method: Browser>>buildMessageCategoryBrowserEditString: (in category 'message category functions') ----- - buildMessageCategoryBrowserEditString: aString - "Create and schedule a new class browser for the current selection, - with initial textual contents set to aString. This is used specifically in - spawning where a class is established but a method-category is not." - ^ self hasMessageCategorySelected ifTrue: [Browser - newOnClass: self selectedClassOrMetaClass - messageCategory: self selectedMessageCategoryName - selector: self selectedMessageName - editString: aString - label: 'Message category Browser: ' , self selectedClassOrMetaClass name , self categoryOfCurrentMethod]! Item was removed: - ----- Method: Browser>>buildMessageCategoryListWith: (in category 'toolbuilder') ----- - buildMessageCategoryListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #messageCategoryList; - list: #messageCategoryList; - getIndex: #messageCategoryListIndex; - setIndex: #messageCategoryListIndex:; - menu: #messageCategoryMenu:; - keyPress: #messageCategoryListKey:from:. - SystemBrowser browseWithDragNDrop ifTrue:[ - listSpec - dropAccept: #wantsMessageCategoriesDrop:; - dropItem: #dropOnMessageCategories:at:]. - ^listSpec - ! Item was removed: - ----- Method: Browser>>buildMessageListCatSingletonWith: (in category 'toolbuilder') ----- - buildMessageListCatSingletonWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #messageCatListSingleton; - getIndex: #indexIsOne; - setIndex: #indexIsOne:; - menu: #messageCategoryMenu:; - hScrollBarPolicy: #never; - vScrollBarPolicy: #never; - minimumHeight: 0. - ^listSpec - ! Item was removed: - ----- Method: Browser>>buildMessageListWith: (in category 'toolbuilder') ----- - buildMessageListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #messageList; - list: #messageList; - getIndex: #messageListIndex; - setIndex: #messageListIndex:; - icon: #messageIconAt:; - helpItem: #messageHelpAt:; - menu: #messageListMenu:shifted:; - keyPress: #messageListKey:from:. - SystemBrowser browseWithDragNDrop ifTrue: [ - listSpec - dragItem: #dragFromMessageList:; - dragType: #dragTypeForMessageListAt:]. - ^listSpec - ! Item was removed: - ----- Method: Browser>>buildSwitchesWith: (in category 'toolbuilder') ----- - buildSwitchesWith: builder - "Build the instance/comment/class switch" - - | panelSpec i q c | - panelSpec := builder pluggablePanelSpec new - name: #switches; - layout: #horizontal; - spacing: (-1 * RealEstateAgent scaleFactor) truncated; - children: OrderedCollection new; - yourself. - - i := builder pluggableButtonSpec new. - i - model: self; - label: 'instance'; - help: 'Show instance-side methods' translated; - state: #instanceMessagesIndicated; - action: #indicateInstanceMessages. - - q := builder pluggableButtonSpec new. - q - model: self; - horizontalResizing: #shrinkWrap; - label: '?'; - help: 'Cycle between definition, comment, and hierarchy view' translated; - state: #classCommentIndicated; - action: #plusButtonHit. - - c := builder pluggableButtonSpec new. - c - model: self; - label: 'class'; - help: 'Show class-side methods' translated; - state: #classMessagesIndicated; - action: #indicateClassMessages. - - panelSpec children addAll: { - i. c. - builder pluggableSpacerSpec new. - q - }. - - ^panelSpec! Item was removed: - ----- Method: Browser>>buildSystemCatListSingletonWith: (in category 'toolbuilder') ----- - buildSystemCatListSingletonWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #systemCategorySingleton; - getIndex: #indexIsOne; - setIndex: #indexIsOne:; - menu: #systemCategoryMenu:; - keyPress: #systemCatSingletonKey:from:; - hScrollBarPolicy: #never; - vScrollBarPolicy: #never; - minimumHeight: 0. - ^listSpec! Item was removed: - ----- Method: Browser>>buildSystemCategoryBrowser (in category 'system category functions') ----- - buildSystemCategoryBrowser - "Open a new system category browser on the selelcted category, if there is one" - - self hasSystemCategorySelected - ifTrue: - [self class newOnCategory: self selectedSystemCategory]! Item was removed: - ----- Method: Browser>>buildSystemCategoryBrowserEditString: (in category 'system category functions') ----- - buildSystemCategoryBrowserEditString: aString - "Open a new system category browser on the selelcted category, if - there is one" - self hasSystemCategorySelected - ifTrue: [self class - newOnCategory: self selectedSystemCategory - editString: aString - label: 'Classes in category ' , self selectedSystemCategory]! Item was removed: - ----- Method: Browser>>buildSystemCategoryListWith: (in category 'toolbuilder') ----- - buildSystemCategoryListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #systemCategoryList; - list: #systemCategoryList; - getIndex: #systemCategoryListIndex; - setIndex: #systemCategoryListIndex:; - menu: #systemCategoryMenu:; - keyPress: #systemCatListKey:from:. - SystemBrowser browseWithDragNDrop ifTrue:[ - listSpec - dropAccept: #wantsSystemCategoriesDrop:; - dropItem: #dropOnSystemCategories:at:]. - ^listSpec! Item was removed: - ----- Method: Browser>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "Create the ui for the browser" - "Browser is a bit of an oddity in the ToolBuilder>build: world since the class provides several dfferent UIs rather than the one-per-class idiom of ToolBuilder. Here we are building the full browser version" - - ^self buildDefaultBrowserWith: builder ! Item was removed: - ----- Method: Browser>>canShowMultipleMessageCategories (in category 'message category functions') ----- - canShowMultipleMessageCategories - "Answer whether the receiver is capable of showing multiple message categories" - - ^ true! Item was removed: - ----- Method: Browser>>categorizeAllUncategorizedMethods (in category 'message category list') ----- - categorizeAllUncategorizedMethods - "Categorize methods by looking in parent classes for a method category." - - self classOrMetaClassOrganizer classifyAllUnclassified. - self changed: #messageCategoryList! Item was removed: - ----- Method: Browser>>categoryOfCurrentMethod (in category 'message category functions') ----- - categoryOfCurrentMethod - "Determine the method category associated with the receiver at the current moment, or nil if none" - - | aCategory | - ^ super categoryOfCurrentMethod ifNil: - [(aCategory := self messageCategoryListSelection) == ClassOrganizer allCategory - ifTrue: - [nil] - ifFalse: - [aCategory]]! Item was removed: - ----- Method: Browser>>changeMessageCategories: (in category 'message category functions') ----- - changeMessageCategories: aString - "The characters in aString represent an edited version of the the message - categories for the selected class. Update this information in the system - and inform any dependents that the categories have been changed. This - message is invoked because the user had issued the categories command - and edited the message categories. Then the user issued the accept - command." - - self classOrMetaClassOrganizer changeFromString: aString. - self clearUserEditFlag. - self editClass. - self selectClassNamed: selectedClassName. - ^ true! Item was removed: - ----- Method: Browser>>changeSystemCategories: (in category 'system category functions') ----- - changeSystemCategories: aString - "Update the class categories by parsing the argument aString." - - systemOrganizer changeFromString: aString. - self changed: #systemCategoryList. - ^ true! Item was removed: - ----- Method: Browser>>classCommentIndicated (in category 'metaclass') ----- - classCommentIndicated - "Answer true iff we're viewing the class comment." - - ^ editSelection == #editComment - ! Item was removed: - ----- Method: Browser>>classCommentText (in category 'class functions') ----- - classCommentText - "return the text to display for the comment of the currently selected class" - | theClass | - theClass := self selectedClassOrMetaClass. - theClass ifNil: [ ^'']. - - ^ theClass hasComment - ifTrue: [ theClass comment ] - ifFalse: [ self noCommentNagString ]! Item was removed: - ----- Method: Browser>>classDefinitionIndicated (in category 'metaclass') ----- - classDefinitionIndicated - - ^ editSelection == #editClass - ! Item was removed: - ----- Method: Browser>>classDefinitionText (in category 'class functions') ----- - classDefinitionText - "return the text to display for the definition of the currently selected class" - | theClass | - ^(theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass definition]! Item was removed: - ----- Method: Browser>>classIconAt: (in category 'class list') ----- - classIconAt: anIndex - - self class showClassIcons - ifFalse: [^ nil]. - - ^ ToolIcons iconNamed: (ToolIcons iconForClass: (self classList at: anIndex) withBlanksTrimmed asSymbol)! Item was removed: - ----- Method: Browser>>classList (in category 'class list') ----- - classList - - ^ self class listClassesHierarchically - ifTrue: [self hierarchicalClassList] - ifFalse: [self defaultClassList].! Item was removed: - ----- Method: Browser>>classListFrame: (in category 'initialize-release') ----- - classListFrame: bottomFraction - ^self - classListFrame: bottomFraction - fromTop: 0 - fromLeft: 0.25 - width: 0.25.! Item was removed: - ----- Method: Browser>>classListFrame:fromLeft:width: (in category 'initialize-release') ----- - classListFrame: bottomFraction fromLeft: leftFraction width: rightFraction - ^self - classListFrame: bottomFraction - fromTop: 0 - fromLeft: leftFraction - width: rightFraction.! Item was removed: - ----- Method: Browser>>classListFrame:fromTop:fromLeft:width: (in category 'initialize-release') ----- - classListFrame: bottomFraction fromTop: topFraction fromLeft: leftFraction width: rightFraction - ^LayoutFrame new - leftFraction: leftFraction offset: 0; - topFraction: topFraction offset: 0; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: bottomFraction offset: self buttonHeight negated! Item was removed: - ----- Method: Browser>>classListIndex (in category 'class list') ----- - classListIndex - "Answer the index of the current class selection." - - ^ self classListIndexOf: self selectedClassName.! Item was removed: - ----- Method: Browser>>classListIndex: (in category 'class list') ----- - classListIndex: anInteger - | newClassName | - newClassName := self classList at: anInteger ifAbsent: [ nil ]. - newClassName := newClassName ifNotNil: [newClassName withoutLeadingBlanks asSymbol]. - self selectClassNamed: newClassName.! Item was removed: - ----- Method: Browser>>classListIndexOf: (in category 'class list') ----- - classListIndexOf: className - - | classList | - classList := self classList. - classList := classList collect: [:ea | ea withoutLeadingBlanks asSymbol]. - ^ classList indexOf: className.! Item was removed: - ----- Method: Browser>>classListMenu: (in category 'class functions') ----- - classListMenu: aMenu - "Conveniently fit for backward compatibility with old browers stored in image segments" - <classListMenuShifted: false> - aMenu addList: #( - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' spawnHierarchy) - ('browse protocol (p)' browseFullProtocol) - ('browse documentation' browseAllCommentsForClass) - - - ('printOut' printOutClass) - ('fileOut' fileOutClass) - - - ('show hierarchy' hierarchy) - ('show definition' editClass) - ('show comment' editComment) - - - ('references... (r)' browseVariableReferences) - ('assignments... (a)' browseVariableAssignments) - ('class refs (N)' browseClassRefs) - - - ('rename class ...' renameClass) - ('copy class' copyClass) - ('remove class (x)' removeClass) - - - ('find method...' findMethod)). - ^ aMenu - ! Item was removed: - ----- Method: Browser>>classListMenu:shifted: (in category 'class functions') ----- - classListMenu: aMenu shifted: shifted - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - ^ self menu: aMenu for: #(classListMenu classListMenuShifted:) shifted: shifted. - ! Item was removed: - ----- Method: Browser>>classListMenuHook:shifted: (in category 'pluggable menus - hooks') ----- - classListMenuHook: aMenu shifted: aBoolean - <classListMenu> - <menuPriority: 400> - ^ self menuHook: aMenu named: #classListMenu shifted: aBoolean. - ! Item was removed: - ----- Method: Browser>>classListMenuMore: (in category 'class functions') ----- - classListMenuMore: aMenu - " The 'more..' link that toggles between shifted and unshifted menus - in class lists " - <classListMenuShifted: false> - <menuPriority: 1000> - ^ aMenu addList: #(- ('more...' offerShiftedClassListMenu)); yourself - ! Item was removed: - ----- Method: Browser>>classListSingleton (in category 'class list') ----- - classListSingleton - - | name | - name := self selectedClassName. - ^ name ifNil: [Array new] - ifNotNil: [Array with: name]! Item was removed: - ----- Method: Browser>>classMessagesIndicated (in category 'metaclass') ----- - classMessagesIndicated - "Answer whether the messages to be presented should come from the - metaclass." - - ^ self metaClassIndicated and: [self classCommentIndicated not]! Item was removed: - ----- Method: Browser>>classNotFound (in category 'system category functions') ----- - classNotFound - - self changed: #flash.! Item was removed: - ----- Method: Browser>>classOrMetaClassOrganizer (in category 'metaclass') ----- - classOrMetaClassOrganizer - "Answer the class organizer for the metaclass or class, depending on - which (instance or class) is indicated." - - self metaClassIndicated - ifTrue: [^metaClassOrganizer] - ifFalse: [^classOrganizer]! Item was removed: - ----- Method: Browser>>compileMessage:notifying: (in category 'code pane') ----- - compileMessage: aText notifying: aController - "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." - | fallBackCategoryName originalSelectorName result fallBackMethodName | - self selectedMessageCategoryName = ClassOrganizer allCategory - ifTrue: - [ "User tried to save a method while the ALL category was selected" - fallBackCategoryName := selectedMessageCategoryName. - fallBackMethodName := selectedMessageName. - editSelection == #newMessage - ifTrue: - [ "Select the 'as yet unclassified' category" - selectedMessageCategoryName := nil. - (result := self defineMessageFrom: aText notifying: aController) - ifNil: - ["Compilation failure: reselect the original category & method" - selectedMessageCategoryName := fallBackCategoryName. - selectedMessageName := fallBackMethodName] - ifNotNil: - [self setSelector: result]] - ifFalse: - [originalSelectorName := self selectedMessageName. - self setOriginalCategoryIndexForCurrentMethod. - selectedMessageName := fallBackMethodName := originalSelectorName. - (result := self defineMessageFrom: aText notifying: aController) - ifNotNil: - [self setSelector: result] - ifNil: - [ "Compilation failure: reselect the original category & method" - selectedMessageCategoryName := fallBackCategoryName. - selectedMessageName := fallBackMethodName. - ^ result notNil]]. - self changed: #messageCategoryList. - self changed: #messageList. - ^ result notNil] - ifFalse: - [ "User tried to save a method while the ALL category was NOT selected" - ^ (self defineMessageFrom: aText notifying: aController) notNil]! Item was removed: - ----- Method: Browser>>contents (in category 'accessing') ----- - contents - "Depending on the current selection, different information is retrieved. - Answer a string description of that information. This information is the - method of the currently selected class and message." - - | comment theClass latestCompiledMethod | - latestCompiledMethod := currentCompiledMethod. - currentCompiledMethod := nil. - - editSelection == #newTrait - ifTrue: [^ClassDescription newTraitTemplateIn: self selectedSystemCategory]. - editSelection == #none ifTrue: [^ '']. - editSelection == #editSystemCategories - ifTrue: [^ systemOrganizer printString]. - editSelection == #newClass - ifTrue: [^ self newClassContents]. - editSelection == #editClass - ifTrue: [^self classDefinitionText]. - editSelection == #editComment - ifTrue: - [(theClass := self selectedClass) ifNil: [^ '']. - comment := theClass comment. - currentCompiledMethod := classOrganizer commentRemoteStr. - ^ comment size = 0 - ifTrue: ['This class has not yet been commented.'] - ifFalse: [comment]]. - editSelection == #hierarchy - ifTrue: [^self selectedClassOrMetaClass printHierarchy]. - editSelection == #editMessageCategories - ifTrue: [^ self classOrMetaClassOrganizer printString]. - editSelection == #newMessage - ifTrue: - [^ (theClass := self selectedClassOrMetaClass) - ifNil: [''] - ifNotNil: [theClass sourceCodeTemplate]]. - editSelection == #editMessage - ifTrue: - [^ self editContentsWithDefault: - [currentCompiledMethod := latestCompiledMethod. - self selectedMessage]]. - - self error: 'Browser internal error: unknown edit selection.'! Item was removed: - ----- Method: Browser>>contents:notifying: (in category 'accessing') ----- - contents: input notifying: aController - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment, - hierarchy). Answer the result of updating the source." - - | aString aText theClass | - self changed: #annotation. - aString := input asString. - aText := input asText. - editSelection == #newTrait ifTrue: [^self defineTrait: input asString notifying: aController]. - editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. - editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. - editSelection == #editComment - ifTrue: - [theClass := self selectedClass. - theClass - ifNil: - [self inform: 'You must select a class - before giving it a comment.'. - ^ false]. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - editSelection == #hierarchy ifTrue: [^ true]. - editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. - editSelection == #editMessage | (editSelection == #newMessage) - ifTrue: - [^ self okayToAccept - ifFalse: - [false] - ifTrue: - [self compileMessage: aText notifying: aController]]. - editSelection == #none - ifTrue: - [self inform: 'This text cannot be accepted - in this part of the browser.'. - ^ false]. - self error: 'unacceptable accept'! Item was removed: - ----- Method: Browser>>contentsSelection (in category 'accessing') ----- - contentsSelection - "Return the interval of text in the code pane to select when I set the pane's contents" - - self hasMessageCategorySelected & (self hasMessageSelected not) - ifTrue: [^ 1 to: 500] "entire empty method template" - ifFalse: [^ 1 to: 0] "null selection"! Item was removed: - ----- Method: Browser>>copyClass (in category 'class functions') ----- - copyClass - | originalClass originalName copysName | - self hasClassSelected ifFalse: [^ self]. - self okToChange ifFalse: [^ self]. - originalClass := self selectedClass. - originalName := originalClass name. - copysName := self request: 'Please type new class name' initialAnswer: originalName. - copysName = '' ifTrue: [^ self]. " Cancel returns '' " - copysName := copysName asSymbol. - copysName = originalName ifTrue: [^ self]. - (self environment hasClassNamed: copysName) - ifTrue: [^ self error: copysName , ' already exists']. - Cursor wait showWhile: [ - | newDefinition newMetaDefinition newClass | - newDefinition := originalClass definition - copyReplaceAll: originalName printString - with: copysName printString. - newClass := Compiler evaluate: newDefinition environment: self environment - logged: true. - newMetaDefinition := originalClass class definition - copyReplaceAll: originalClass class name - with: newClass class name. - Compiler evaluate: newMetaDefinition environment: self environment - logged: true. - newClass copyAllCategoriesFrom: originalClass. - newClass class copyAllCategoriesFrom: originalClass class. - originalClass hasComment ifTrue: [ - newClass comment: originalClass comment ] ]. - self classListIndex: 0. - self changed: #classList! Item was removed: - ----- Method: Browser>>couldBrowseAnyClass (in category 'accessing') ----- - couldBrowseAnyClass - "Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name. This implementation is clearly ugly, but the feature it enables is handsome enough. 3/1/96 sw" - - ^self dependents - anySatisfy: [:d | (d respondsTo: #getListSelector) - and: [d getListSelector == #systemCategoryList]]! Item was removed: - ----- Method: Browser>>createHierarchyTreeOf: (in category 'class list') ----- - createHierarchyTreeOf: col - - "Create a tree from a flat collection of classes" - | transformed | - transformed := col collect: [:ea | - | childs indexes | - childs := col select: [:class | class isTrait not and: [class superclass = ea]]. - indexes := childs collect: [:child | col indexOf: child]. - ea -> indexes]. - transformed copy do: [:ea | - ea value: (ea value collect: [:idx | - | val | - val := transformed at: idx. - transformed at: idx put: nil. - val])]. - ^ transformed select: [:ea | ea notNil]. - ! Item was removed: - ----- Method: Browser>>createInstVarAccessors (in category 'class functions') ----- - createInstVarAccessors - - self selectedClassOrMetaClass - ifNotNil: [:aClass | aClass createInstVarAccessors]. - ! Item was removed: - ----- Method: Browser>>decorateButtons (in category 'controls') ----- - decorateButtons - - super decorateButtons. - - self changed: #classCommentIndicated. - self changed: #instanceMessagesIndicated. - self changed: #classMessagesIndicated.! Item was removed: - ----- Method: Browser>>defaultBrowserTitle (in category 'initialize-release') ----- - defaultBrowserTitle - | title | - title := 'System Browser'. - ^ self environment = self class environment - ifTrue: [title] - ifFalse: [title, ' on environment ', self environment asString]! Item was removed: - ----- Method: Browser>>defaultClassList (in category 'class list') ----- - defaultClassList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - - ^ self hasSystemCategorySelected - ifFalse: [Array new] - ifTrue: [self selectedSystemCategory = SystemOrganizer allCategory - ifTrue: [systemOrganizer allElements sort] - ifFalse: [systemOrganizer listAtCategoryNamed: self selectedSystemCategory]] - ! Item was removed: - ----- Method: Browser>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.764 g: 0.9 b: 0.63)! Item was removed: - ----- Method: Browser>>defineClass:notifying: (in category 'class functions') ----- - defineClass: defString notifying: aController - "The receiver's textual content is a request to define a new class. The - source code is defString. If any errors occur in compilation, notify - aController." - | oldClass class newClassName defTokens keywdIx envt | - oldClass := self selectedClassOrMetaClass. - defTokens := defString findTokens: Character separators. - - ((defTokens first = 'Trait' and: [defTokens second = 'named:']) - or: [defTokens second = 'classTrait']) - ifTrue: [^self defineTrait: defString notifying: aController]. - - keywdIx := defTokens findFirst: [:x | x beginsWith: 'category']. - envt := self selectedEnvironment. - keywdIx := defTokens findFirst: [:x | '*subclass*' match: x]. - newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. - ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) - and: [envt includesKey: newClassName asSymbol]) ifTrue: - ["Attempting to define new class over existing one when - not looking at the original one in this browser..." - (self confirm: ((newClassName , ' is an existing class in this system. - Redefining it might cause serious problems. - Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) - ifFalse: [^ false]]. - "ar 8/29/1999: Use oldClass superclass for defining oldClass - since oldClass superclass knows the definerClass of oldClass." - oldClass ifNotNil:[oldClass := oldClass superclass]. - class := envt beCurrentDuring: - [oldClass subclassDefinerClass - evaluate: defString - in: envt - notifying: aController - logged: false]. - (class isKindOf: Behavior) - ifTrue: [self changed: #systemCategoryList; changed: #classList. - self clearUserEditFlag; spawnOrNavigateTo: class. - ^ true] - ifFalse: [^ false]! Item was removed: - ----- Method: Browser>>defineMessageFrom:notifying: (in category 'message functions') ----- - defineMessageFrom: aString notifying: aController - "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." - | currentSelector selector category oldMessageList selectedClassOrMetaClass | - currentSelector := self selectedMessageName. - oldMessageList := self messageList. - selectedClassOrMetaClass := self selectedClassOrMetaClass. - contents := nil. - selector := (selectedClassOrMetaClass newParser parseSelector: aString). - (self metaClassIndicated - and: [(selectedClassOrMetaClass includesSelector: selector) not - and: [Metaclass isScarySelector: selector]]) - ifTrue: ["A first-time definition overlaps the protocol of Metaclasses" - (self confirm: ((selector , ' is used in the existing class system. - Overriding it could cause serious problems. - Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size)) - ifFalse: [^nil]]. - category := currentSelector - ifNil: [ self selectedMessageCategoryName ] - ifNotNil: [ (selectedClassOrMetaClass >> selectedMessageName) methodReference ifNotNil: [ : ref | ref category ]]. - selector := selectedClassOrMetaClass - compile: aString - classified: category - notifying: aController. - selector ifNil: [^ nil]. - contents := aString copy. - - self changed: #messageCategoryList. "Because the 'as yet unclassified' might just appear." - self changed: #messageList. "Because we have code-dependent list formatting by now such as #isDeprecated." - - selector ~~ currentSelector - ifTrue: - [category = ClassOrganizer nullCategory - ifTrue: [self changed: #classSelectionChanged. - self changed: #classList. - self messageCategoryListIndex: 1]. - self setClassOrganizer. "In case organization not cached" - (oldMessageList includes: selector) - ifFalse: [self changed: #messageList]. - self messageListIndex: (self messageList indexOf: selector)]. - ^ selector! Item was removed: - ----- Method: Browser>>defineTrait:notifying: (in category 'traits') ----- - defineTrait: defString notifying: aController - - | defTokens keywdIx envt oldTrait newTraitName trait | - oldTrait := self selectedClassOrMetaClass. - defTokens := defString findTokens: Character separators. - keywdIx := defTokens findFirst: [:x | x = 'category']. - envt := self selectedEnvironment. - keywdIx := defTokens findFirst: [:x | x = 'named:']. - newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. - ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName]) - and: [envt includesKey: newTraitName asSymbol]) ifTrue: - ["Attempting to define new class/trait over existing one when - not looking at the original one in this browser..." - (self confirm: ((newTraitName , ' is an existing class/trait in this system. - Redefining it might cause serious problems. - Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size)) - ifFalse: [^ false]]. - - trait := envt beCurrentDuring: - [Compiler evaluate: defString in: envt notifying: aController logged: true]. - ^(trait isTrait) - ifTrue: [ - self changed: #classList. - self classListIndex: (self classListIndexOf: trait baseTrait name). - self clearUserEditFlag; editClass. - true] - ifFalse: [ false ] - ! Item was removed: - ----- Method: Browser>>didCodeChangeElsewhere (in category 'self-updating') ----- - didCodeChangeElsewhere - - super didCodeChangeElsewhere ifTrue: - [^true]. - self classDefinitionIndicated ifFalse: - [^false]. - ^self metaClassIndicated - ifFalse: - [classDefinition ~= (self selectedClass ifNotNil: [:selectedClass| selectedClass definition])] - ifTrue: - [metaClassDefinition ~= (self selectedClass ifNotNil: [:selectedClass| selectedClass theMetaClass definition])]! Item was removed: - ----- Method: Browser>>dragFromClassList: (in category 'drag and drop') ----- - dragFromClassList: index - "Drag a class from the browser" - | name envt | - (name := self classList at: index) ifNil: [ ^ nil ]. - (envt := self selectedEnvironment) ifNil: [ ^ nil ]. - ^ envt - at: name withBlanksTrimmed asSymbol - ifAbsent: [ ]! Item was removed: - ----- Method: Browser>>dragFromMessageList: (in category 'drag and drop') ----- - dragFromMessageList: index - "Drag a method from the browser" - - | selector | - self flag: #refactor. "mt: Maybe use an approach similar to MessageSet class >> #parse:toClassAndSelector instead of #asString? There could be any fancy representation of a message in the message list." - selector := Symbol lookup: (self messageList at: index) asString. - selector ifNil: [^ self]. - - ^self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent:[nil]! Item was removed: - ----- Method: Browser>>dragTypeForClassListAt: (in category 'drag and drop') ----- - dragTypeForClassListAt: index - - ^ #sourceCode! Item was removed: - ----- Method: Browser>>dragTypeForMessageListAt: (in category 'drag and drop') ----- - dragTypeForMessageListAt: index - - ^ #sourceCode! Item was removed: - ----- Method: Browser>>dropOnMessageCategories:at: (in category 'drag and drop') ----- - dropOnMessageCategories: method at: index - - | sourceClass destinationClass category copy | - copy := Sensor shiftPressed. - (method isKindOf: CompiledMethod) - ifFalse:[^self inform: 'Can only drop methods']. - sourceClass := method methodClass. - destinationClass := self selectedClassOrMetaClass. - sourceClass == destinationClass ifTrue:[ - category := self messageCategoryList at: index. - category = ClassOrganizer allCategory ifTrue: [^false]. - destinationClass organization classify: method selector under: category suppressIfDefault: false logged: true. - self changed: #messageCategoryList. - self changed: #messageList. - ^true ]. - (copy - or: [ (destinationClass inheritsFrom: sourceClass) - or: [ (sourceClass inheritsFrom: destinationClass) - or: [ sourceClass theNonMetaClass == destinationClass theNonMetaClass ] ] ]) - ifFalse: [ - (self confirm: ( - 'Classes "{1}" and "{2}" are unrelated.{3}Are you sure you want to move this method?' - translated format: { sourceClass. destinationClass. Character cr })) - ifFalse: [ ^false ] ]. - destinationClass - compile: method getSource - classified: (self messageCategoryList at: index) - withStamp: method timeStamp - notifying: nil. - copy ifFalse: [ - sourceClass removeSelector: method selector ]. - ^true! Item was removed: - ----- Method: Browser>>dropOnSystemCategories:at: (in category 'drag and drop') ----- - dropOnSystemCategories: aClass at: index - | category | - (aClass isBehavior) ifFalse:[^self inform: 'Can only drop classes']. - category := self systemCategoryList at: index. - self selectedEnvironment organization classify: aClass instanceSide name under: category. - self changed: #systemCategoryList. - self changed: #classList. - ^true! Item was removed: - ----- Method: Browser>>editClass (in category 'class functions') ----- - editClass - "Retrieve the description of the class definition." - - self hasClassSelected ifFalse: [^ self]. - self okToChange ifFalse: [^ self]. - self messageCategoryListIndex: 0. - self editSelection: #editClass. - self changed: #contents. - self changed: #classCommentText. - ! Item was removed: - ----- Method: Browser>>editComment (in category 'class functions') ----- - editComment - "Retrieve the description of the class comment." - - self hasClassSelected ifFalse: [^ self]. - self okToChange ifFalse: [^ self]. - self messageCategoryListIndex: 0. - metaClassIndicated := false. - self editSelection: #editComment. - self changed: #classSelectionChanged. - self changed: #messageCategoryList. - self changed: #messageList. - self decorateButtons. - self contentsChanged - ! Item was removed: - ----- Method: Browser>>editMessageCategories (in category 'message category functions') ----- - editMessageCategories - "Indicate to the receiver and its dependents that the message categories of - the selected class have been changed." - - self okToChange ifFalse: [^ self]. - self hasClassSelected - ifTrue: - [self messageCategoryListIndex: 0. - self editSelection: #editMessageCategories. - self changed: #editMessageCategories. - self contentsChanged]! Item was removed: - ----- Method: Browser>>editSelection (in category 'accessing') ----- - editSelection - ^editSelection! Item was removed: - ----- Method: Browser>>editSelection: (in category 'accessing') ----- - editSelection: aSelection - "Set the editSelection as requested." - - editSelection := aSelection. - self changed: #editSelection.! Item was removed: - ----- Method: Browser>>editSystemCategories (in category 'system category functions') ----- - editSystemCategories - "Retrieve the description of the class categories of the system organizer." - - self okToChange ifFalse: [^ self]. - self selectSystemCategory: nil. - self editSelection: #editSystemCategories. - self changed: #editSystemCategories. - self contentsChanged! Item was removed: - ----- Method: Browser>>environment (in category 'accessing') ----- - environment - ^ environment ifNil: [Environment default]! Item was removed: - ----- Method: Browser>>explainSpecial: (in category 'class functions') ----- - explainSpecial: string - "Answer a string explaining the code pane selection if it is displaying - one of the special edit functions." - - | classes whole lits reply | - (editSelection == #editClass or: [editSelection == #newClass]) - ifTrue: - ["Selector parts in class definition" - string last == $: ifFalse: [^nil]. - lits := Array with: - #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. - (whole := lits - detect: [:each | each keywords anySatisfy: [:frag | frag = string] ] - ifNone: []) ~~ nil - ifTrue: [reply := '"' , string , ' is one part of the message selector ' , whole , '.'] - ifFalse: [^nil]. - classes := self systemNavigation allClassesImplementing: whole. - classes := 'these classes ' , classes printString. - ^reply , ' It is defined in ' , classes , '." - Smalltalk browseAllImplementorsOf: #' , whole]. - - editSelection == #hierarchy - ifTrue: - ["Instance variables in subclasses" - classes := self selectedClassOrMetaClass allSubclasses. - classes := classes - detect: [:each | each instVarNames anySatisfy: [:name | name = string] ] - ifNone: [^nil]. - classes := classes printString. - ^'"is an instance variable in class ' , classes , '." - ' , classes , ' browseAllAccessesTo: ''' , string , '''.']. - editSelection == #editSystemCategories ifTrue: [^nil]. - editSelection == #editMessageCategories ifTrue: [^nil]. - ^nil! Item was removed: - ----- Method: Browser>>fileOutClass (in category 'class functions') ----- - fileOutClass - "Print a description of the selected class onto a file whose name is the - category name followed by .st." - - Cursor write showWhile: - [self hasClassSelected ifTrue: [self selectedClass fileOut]]! Item was removed: - ----- Method: Browser>>fileOutMessageCategories (in category 'message category functions') ----- - fileOutMessageCategories - "Print a description of the selected message category of the selected class - onto an external file." - - Cursor write showWhile: - [self hasMessageCategorySelected - ifTrue: - [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! Item was removed: - ----- Method: Browser>>fileOutSystemCategory (in category 'system category functions') ----- - fileOutSystemCategory - "Print a description of each class in the selected category onto a file - whose name is the category name followed by .st." - - self hasSystemCategorySelected - ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategory]! Item was removed: - ----- Method: Browser>>findClass (in category 'system category functions') ----- - findClass - "Search for a class by name." - - | foundClass | - (self multiWindowState notNil - or: [self okToChange]) ifFalse: - [^self classNotFound]. - foundClass := Project uiManager chooseClassOrTraitFrom: self environment withRecentList: self recentClassListFormatted. - foundClass ifNil: [^self classNotFound]. - (self selectedClass notNil - and: [self multiWindowState notNil - "Can only support multi-window if original window has all the right panes." - and: [self multiWindowState prototype isHierarchy not]]) ifTrue: - [(self classList includes: foundClass name) - ifTrue: [self multiWindowState copyWindow] - ifFalse: [self multiWindowState addNewWindow]]. - self selectCategoryForClass: foundClass. - self selectClass: foundClass! Item was removed: - ----- Method: Browser>>findMethod (in category 'class functions') ----- - findMethod - "Pop up a list of the current class's methods, and select the one chosen by the user" - | aClass selectors reply cat messageCatIndex messageIndex | - self classListIndex = 0 ifTrue: [^ self]. - self okToChange ifFalse: [^ self]. - aClass := self selectedClassOrMetaClass. - selectors := aClass selectors sorted. - selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self]. - reply := UIManager default - chooseFrom: selectors - values: selectors - lines: #(1). - reply ifNil: [^ self]. - cat := aClass whichCategoryIncludesSelector: reply. - messageCatIndex := self messageCategoryList indexOf: cat. - self messageCategoryListIndex: messageCatIndex. - messageIndex := (self messageList indexOf: reply). - self messageListIndex: messageIndex! Item was removed: - ----- Method: Browser>>flattenHierarchyTree:on:indent: (in category 'class list') ----- - flattenHierarchyTree: classHierarchy on: col indent: indent - ^ self - flattenHierarchyTree: classHierarchy - on: col - indent: indent - by: ' '.! Item was removed: - ----- Method: Browser>>flattenHierarchyTree:on:indent:by: (in category 'class list') ----- - flattenHierarchyTree: classHierarchy on: col indent: indent by: indentChars - ^ self - flattenHierarchyTree: classHierarchy - on: col - indent: indent - by: indentChars - format: [:class | class name]! Item was removed: - ----- Method: Browser>>flattenHierarchyTree:on:indent:by:format: (in category 'class list') ----- - flattenHierarchyTree: classHierarchy on: col indent: indent by: indentChars format: formatBlock - "Recursively add to col the names in classHierarchy indenting to show the hierarchical relationship. Use indentChars to do the indenting: spaces, tabs, etc." - | plusIndent | - plusIndent := indentChars. - classHierarchy do: [:assoc | - | class childs label | - class := assoc key. - label := formatBlock value: class. - label isText - ifTrue: [col add: (Text string: indent attributes: (label attributesAt: 1)), label] - ifFalse: [col add: indent, label]. - childs := assoc value. - self - flattenHierarchyTree: childs - on: col - indent: indent , plusIndent - by: indentChars - format: formatBlock]. - ^ col! Item was removed: - ----- Method: Browser>>frameOffsetFromTop:fromLeft:width:bottomFraction: (in category 'initialize-release') ----- - frameOffsetFromTop: height fromLeft: leftFraction width: rightFraction bottomFraction: bottomFraction - ^LayoutFrame new - topFraction: 0 offset: height; - leftFraction: leftFraction offset: 0; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: bottomFraction offset: 0; - yourself.! Item was removed: - ----- Method: Browser>>hasClassSelected (in category 'class list') ----- - hasClassSelected - ^ selectedClassName notNil and: [(self environment classNamed: selectedClassName) notNil]! Item was removed: - ----- Method: Browser>>hasMessageCategorySelected (in category 'message category list') ----- - hasMessageCategorySelected - ^ self selectedMessageCategoryName notNil.! Item was removed: - ----- Method: Browser>>hasMessageSelected (in category 'message list') ----- - hasMessageSelected - ^ self selectedMessageName notNil.! Item was removed: - ----- Method: Browser>>hasSystemCategorySelected (in category 'system category list') ----- - hasSystemCategorySelected - ^ self selectedSystemCategory notNil.! Item was removed: - ----- Method: Browser>>hierarchicalClassList (in category 'class list') ----- - hierarchicalClassList - - "classNames are an arbitrary collection of classNames of the system. - Reorder those class names so that they are sorted and indended by inheritance" - | classes | - "Creating the hierarchy is *really slow* for the full class list. Skip it for now." - self selectedSystemCategory = SystemOrganizer allCategory - ifTrue: [^ self defaultClassList]. - - classes := self defaultClassList collect: [:sym | self environment classNamed: sym]. - ^ self - flattenHierarchyTree: (self createHierarchyTreeOf: classes) - on: OrderedCollection new - indent: ''.! Item was removed: - ----- Method: Browser>>hierarchy (in category 'class functions') ----- - hierarchy - "Display the inheritance hierarchy of the receiver's selected class." - - self hasClassSelected ifFalse: [^ self]. - self okToChange ifFalse: [^ self]. - self messageCategoryListIndex: 0. - self editSelection: #hierarchy. - self changed: #editComment. - self contentsChanged. - ^ self! Item was removed: - ----- Method: Browser>>highlightMessageList:with: (in category 'message category functions') ----- - highlightMessageList: list with: morphList - "Changed by emm to add emphasis in case of breakpoint" - - morphList do:[:each | - | classOrNil methodOrNil | - classOrNil := self selectedClassOrMetaClass. - methodOrNil := classOrNil isNil - ifTrue:[nil] - ifFalse:[classOrNil methodDictionary at: each contents ifAbsent:[]]. - (methodOrNil notNil and:[methodOrNil hasBreakpoint]) - ifTrue:[each contents: ((each contents ,' [break]') asText allBold)]]! Item was removed: - ----- Method: Browser>>indexIsOne (in category 'system category list') ----- - indexIsOne - "When used as a singleton list, index is always one" - ^ 1! Item was removed: - ----- Method: Browser>>indexIsOne: (in category 'system category list') ----- - indexIsOne: value - "When used as a singleton list, can't change it" - - ^ self! Item was removed: - ----- Method: Browser>>indicateClassMessages (in category 'metaclass') ----- - indicateClassMessages - "Indicate that the message selection should come from the metaclass - messages." - - self okToChange ifTrue: [ - self metaClassIndicated: true]! Item was removed: - ----- Method: Browser>>indicateInstanceMessages (in category 'metaclass') ----- - indicateInstanceMessages - "Indicate that the message selection should come from the class (instance) - messages." - - self okToChange ifTrue: [ - self metaClassIndicated: false]! Item was removed: - ----- Method: Browser>>informUnknownPackage (in category 'system category functions') ----- - informUnknownPackage - - self inform: ('The category <b>{1}</b> does not belong to a known package.' translated format: {self selectedSystemCategory}) asTextFromHtml.! Item was removed: - ----- Method: Browser>>inspectInstances (in category 'message functions') ----- - inspectInstances - "Inspect all instances of the selected class. 1/26/96 sw" - - | myClass | - ((myClass := self selectedClassOrMetaClass) isNil or: [myClass isTrait]) - ifFalse: [myClass theNonMetaClass inspectAllInstances] - ! Item was removed: - ----- Method: Browser>>inspectSubInstances (in category 'message functions') ----- - inspectSubInstances - "Inspect all instances of the selected class and all its subclasses 1/26/96 sw" - - | aClass | - ((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait]) - ifFalse: [ - aClass := aClass theNonMetaClass. - aClass inspectSubInstances]. - ! Item was removed: - ----- Method: Browser>>instanceMessagesIndicated (in category 'metaclass') ----- - instanceMessagesIndicated - "Answer whether the messages to be presented should come from the - class." - - ^metaClassIndicated not and: [self classCommentIndicated not]! Item was removed: - ----- Method: Browser>>isHierarchy (in category 'multi-window support') ----- - isHierarchy - ^false! Item was removed: - ----- Method: Browser>>isPackage (in category 'multi-window support') ----- - isPackage - ^false! Item was removed: - ----- Method: Browser>>labelString (in category 'initialize-release') ----- - labelString - | label | - label := self selectedClassName - ifNil: [ self defaultBrowserTitle ] - ifNotNil: [ self defaultBrowserTitle, ': ', self selectedClassName asString ]. - (self multiWindowState notNil - and: [self multiWindowState models size > 1]) ifTrue: - [label := (self multiWindowState models indexOf: self) printString, '. ', label]. - ^label! Item was removed: - ----- Method: Browser>>lastMessageName (in category 'message list') ----- - lastMessageName - ^ self messageList last.! Item was removed: - ----- Method: Browser>>mainMessageCategoryMenu: (in category 'message category functions') ----- - mainMessageCategoryMenu: aMenu - <messageCategoryMenu> - ^ aMenu addList: #( - ('browse' buildMessageCategoryBrowser) - ('print out' printOutMessageCategories) - ('file out' fileOutMessageCategories) - - - ('reorganize' editMessageCategories) - ('alphabetize' alphabetizeMessageCategories) - ('remove empty categories' removeEmptyCategories) - ('categorize all uncategorized' categorizeAllUncategorizedMethods) - ('new category...' addCategory) - - - ('rename...' renameCategory) - ('remove (x)' removeMessageCategory)); - yourself - ! Item was removed: - ----- Method: Browser>>mainMessageListMenu: (in category 'message functions') ----- - mainMessageListMenu: aMenu - <messageListMenuShifted: false> - - ^ aMenu - addTranslatedList: #( - ('what to show...' offerWhatToShowMenu)); - add: (self isBreakOnEntry ifTrue: ['<on>'] ifFalse: ['<off>']) , 'break on entry' translated - action: #toggleBreakOnEntry; - addTranslatedList: #( - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseClassHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage) - ('printOut' printOutMessage) - ('copy selector (c)' copySelector) - ('copy reference (C)' copyReference) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('references... (r)' browseVariableReferences) - ('assignments... (a)' browseVariableAssignments) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage) - ('explore method' exploreMethod) - ('inspect method' inspectMethod)); - yourself! Item was removed: - ----- Method: Browser>>mainPackageMenu: (in category 'system category functions') ----- - mainPackageMenu: aMenu - <packageMenu> - - self selectedPackage ifNil: [ - ^ aMenu - add: '(No package found.)' translated action: #yourself; - yourself]. - - aMenu addList: #( - ('browse package' browsePackage) - #- - ('extensions' browsePackageExtensions)). - - aMenu - add: 'extensions local to ''', self selectedSystemCategory, '''' - action: #browsePackageExtensionsLocalTo. - - aMenu addList: #( - #- - ('dependencies' browsePackageDependencies) - ('inverted dependencies' browsePackageDependenciesInverted)). - - ^ aMenu! Item was removed: - ----- Method: Browser>>mainSystemCategoryMenu: (in category 'system category functions') ----- - mainSystemCategoryMenu: aMenu - <systemCategoryMenu> - aMenu addTranslatedList: #( - ('find class... (f)' findClass) - ('back... (b)' recent) - - - ('browse all' browseAllClasses) - ('browse' buildSystemCategoryBrowser)). - - (Smalltalk isMorphic and: [self selectedPackage notNil]) ifTrue: [ - aMenu - add: ('browse package ''{1}''' translated format: {self selectedPackage name}) - subMenu: (self packageMenu: ((Smalltalk isMorphic - ifTrue: [MenuMorph new defaultTarget: self; yourself] - ifFalse: [CustomMenu new]) - yourself)) - target: self - selector: #yourself - argumentList: #()]. - - aMenu addTranslatedList: #( - - - ('printOut' printOutSystemCategory) - ('fileOut' fileOutSystemCategory) - - - ('reorganize' editSystemCategories) - ('alphabetize' alphabetizeSystemCategories) - - - ('update' updateSystemCategories) - ('add item...' addSystemCategory) - ('rename...' renameSystemCategory) - ('remove (x)' removeSystemCategory)). - ^ aMenu! Item was removed: - ----- Method: Browser>>makeNewSubclass (in category 'class functions') ----- - makeNewSubclass - - self selectedClassOrMetaClass ifNil: [^ self]. - self okToChange ifFalse: [^ self]. - self editSelection: #newClass. - self contentsChanged. - "Force the text view to assume there are changes" - self changed: #editString with: self contents! Item was removed: - ----- Method: Browser>>messageCatListSingleton (in category 'message category list') ----- - messageCatListSingleton - - | name | - name := self selectedMessageCategoryName. - ^ name ifNil: [Array new] - ifNotNil: [Array with: name]! Item was removed: - ----- Method: Browser>>messageCategoryList (in category 'message category list') ----- - messageCategoryList - "Answer the selected category of messages." - - ^ self hasClassSelected - ifFalse: [Array new] - ifTrue: [ {ClassOrganizer allCategory}, - (self class sortMessageCategoriesAlphabetically - ifTrue: [self rawMessageCategoryList sorted] - ifFalse: [self rawMessageCategoryList]) ]! Item was removed: - ----- Method: Browser>>messageCategoryListIndex (in category 'message category list') ----- - messageCategoryListIndex - "Answer the index of the selected message category." - - ^self messageCategoryList indexOf: selectedMessageCategoryName! Item was removed: - ----- Method: Browser>>messageCategoryListIndex: (in category 'message category list') ----- - messageCategoryListIndex: anInteger - "Set the selected message category to be the one indexed by anInteger." - - selectedMessageCategoryName := nil. - self selectMessageCategoryNamed: (self messageCategoryList at: anInteger ifAbsent: [nil]).! Item was removed: - ----- Method: Browser>>messageCategoryListKey:from: (in category 'message category list') ----- - messageCategoryListKey: aCharacter from: view - - aCharacter == $x ifTrue: [ ^self removeMessageCategory ]. - ^self arrowKey: aCharacter from: view - ! Item was removed: - ----- Method: Browser>>messageCategoryListSelection (in category 'message category list') ----- - messageCategoryListSelection - "Return the selected category name or nil." - - ^ ((self messageCategoryList size = 0 - or: [self messageCategoryListIndex = 0]) - or: [self messageCategoryList size < self messageCategoryListIndex]) - ifTrue: [nil] - ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! Item was removed: - ----- Method: Browser>>messageCategoryMenu: (in category 'message category functions') ----- - messageCategoryMenu: aMenu - ^ self menu: aMenu for: #(messageCategoryMenu messageCategoryMenuShifted:) - ! Item was removed: - ----- Method: Browser>>messageCategoryMenuHook:shifted: (in category 'pluggable menus - hooks') ----- - messageCategoryMenuHook: aMenu shifted: aBoolean - <messageCategoryMenu> - <menuPriority: 400> - ^ self menuHook: aMenu named: #messageCategoryMenu shifted: aBoolean. - ! Item was removed: - ----- Method: Browser>>messageHelpAt: (in category 'message list') ----- - messageHelpAt: anIndex - "Show the first n lines of the sources code of the selected message." - - | iconHelp selector method | - Preferences balloonHelpInMessageLists ifFalse: [^ nil]. - self messageList size < anIndex ifTrue: [^ nil]. - - "Items in the message list can be formatted texts." - self flag: #refactor. - selector := Symbol lookup: (self messageList at: anIndex) asString. - selector ifNil: [^ nil]. - - method := self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [^ nil]. - iconHelp := (self messageIconHelpFor: method selector) ifNotEmpty: [:t | - t , Character cr, Character cr]. - - ^ iconHelp asText - append: (self messageHelpForMethod: method); - yourself! Item was removed: - ----- Method: Browser>>messageIconAt: (in category 'message list') ----- - messageIconAt: anIndex - - | selector | - self class showMessageIcons ifFalse: [^ nil]. - - self flag: #refactor. - selector := Symbol lookup: (self messageList at: anIndex ifAbsent: [^nil]) asString. - selector ifNil: [^ nil]. - - ^ self messageIconFor: selector! Item was removed: - ----- Method: Browser>>messageIconFor: (in category 'message list') ----- - messageIconFor: aSelector - - self class showMessageIcons ifFalse: [^ nil]. - - ^ ToolIcons iconNamed: (ToolIcons - iconForClass: self selectedClassOrMetaClass - selector: aSelector)! Item was removed: - ----- Method: Browser>>messageIconHelpFor: (in category 'message list') ----- - messageIconHelpFor: aSelector - - self class showMessageIcons ifFalse: [^ String empty]. - - ^ ToolIconHelp iconHelpNamed: (ToolIcons - iconForClass: self selectedClassOrMetaClass - selector: aSelector)! Item was removed: - ----- Method: Browser>>messageList (in category 'message list') ----- - messageList - "Answer an Array of the message selectors of the currently selected message category. If no category is selected or the '-- all --' category is selected, return all method selectors. Make deprecated messages look gray and struck-out." - - - ^ (self selectedMessageCategoryName isNil or: [self selectedMessageCategoryName = ClassOrganizer allCategory]) - ifTrue: [ - self classOrMetaClassOrganizer - ifNil: [Array new] - ifNotNil: [:organizer | organizer allMethodSelectors collect: [:ea | - self formattedLabel: ea]]] - ifFalse: [ - (self classOrMetaClassOrganizer listAtCategoryNamed: self selectedMessageCategoryName) - collect: [:ea | self formattedLabel: ea]]! Item was removed: - ----- Method: Browser>>messageListIndex (in category 'message list') ----- - messageListIndex - "Answer the index of the selected message selector into the currently - selected message category." - - ^ self messageListIndexOf: self selectedMessageName! Item was removed: - ----- Method: Browser>>messageListIndex: (in category 'message list') ----- - messageListIndex: anInteger - "Set the selected message selector to be the one indexed by anInteger." - - self selectMessageNamed: (self messageList at: anInteger ifPresent: [:lbl | lbl asString] ifAbsent: [nil] )! Item was removed: - ----- Method: Browser>>messageListIndexOf: (in category 'message list') ----- - messageListIndexOf: aString - ^ self messageList indexOf: aString.! Item was removed: - ----- Method: Browser>>messageListMenu:shifted: (in category 'message list') ----- - messageListMenu: aMenu shifted: shifted - "Answer the message-list menu" - ^ self menu: aMenu for: #(messageListMenu messageListMenuShifted:) shifted: shifted - ! Item was removed: - ----- Method: Browser>>messageListMenuHook:shifted: (in category 'pluggable menus - hooks') ----- - messageListMenuHook: aMenu shifted: aBoolean - <messageListMenu> - <menuPriority: 400> - ^ self menuHook: aMenu named: #messageListMenu shifted: aBoolean. - ! Item was removed: - ----- Method: Browser>>metaClassIndicated (in category 'metaclass') ----- - metaClassIndicated - "Answer the boolean flag that indicates which of the method dictionaries, - class or metaclass." - - ^ metaClassIndicated! Item was removed: - ----- Method: Browser>>metaClassIndicated: (in category 'metaclass') ----- - metaClassIndicated: trueOrFalse - "Indicate whether browsing instance or class messages." - - metaClassIndicated := trueOrFalse. - self setClassOrganizer. - self hasSystemCategorySelected ifTrue: - [self editSelection: (self hasClassSelected - ifFalse: [metaClassIndicated - ifTrue: [#none] - ifFalse: [#newClass]] - ifTrue: [#editClass])]. - selectedMessageCategoryName := nil. - selectedMessageName := nil. - contents := nil. - self changed: #classSelectionChanged. - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #contents. - self changed: #annotation. - self decorateButtons - ! Item was removed: - ----- Method: Browser>>methodCategoryChanged (in category 'initialize-release') ----- - methodCategoryChanged - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #annotation. - self messageListIndex: 0! Item was removed: - ----- Method: Browser>>multiWindowName (in category 'multi-window support') ----- - multiWindowName - "Answer the string to display for the receiver in a multi-window." - ^String streamContents: - [:s| | str | - self selectedClass - ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle] - ifNotNil: - [s print: self selectedClass. - self metaClassIndicated ifTrue: - [s nextPutAll: ' class']. - self isHierarchy ifTrue: - [s space; nextPutAll: ' Hierarchy']]. - (str := self selectedMessageName) notNil - ifTrue: [s nextPutAll: '>>'; nextPutAll: str] - ifFalse: - [(str := self selectedMessageCategoryName) notNil - ifTrue: [s space; nextPut: ${; nextPutAll: str; nextPut: $}]]]! Item was removed: - ----- Method: Browser>>multiWindowNameForState: (in category 'multi-window support') ----- - multiWindowNameForState: savedStateMessage - "Answer the string to display for the receiver in a multi-window." - | getarg | - getarg := [:keyword| savedStateMessage arguments at: (savedStateMessage selector keywords indexOf: keyword)]. - ^String streamContents: - [:s| - (getarg value: 'className:') - ifNil: [(getarg value: 'restoreToCategory:') - ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle] - ifNotNil: [:categoryName| s nextPutAll: categoryName]] - ifNotNil: - [:className| - s nextPutAll: className. - (getarg value: 'meta:') ifTrue: - [s nextPutAll: ' class']. - self isHierarchy ifTrue: - [s space; nextPutAll: ' Hierarchy']. - (getarg value: 'selector:') - ifNil: [(getarg value: 'protocol:') ifNotNil: - [:protocol| s space; nextPut: ${; nextPutAll: protocol; nextPut: $}]] - ifNotNil: [:selector| s nextPutAll: '>>'; nextPutAll: selector]]]! Item was removed: - ----- Method: Browser>>newClass (in category 'traits') ----- - newClass - (self selectedClassOrMetaClass notNil and: - [self selectedClassOrMetaClass isTrait]) ifTrue: [self classListIndex: 0]. - self editClass. - editSelection := #newClass. - self contentsChanged! Item was removed: - ----- Method: Browser>>newClassContents (in category 'accessing') ----- - newClassContents - | theClassName | - ^ (theClassName := self selectedClassName) - ifNil: - [Class template: self selectedSystemCategory] - ifNotNil: - [Class templateForSubclassOf: theClassName asString category: self selectedSystemCategory]! Item was removed: - ----- Method: Browser>>newTrait (in category 'traits') ----- - newTrait - self classListIndex: 0. - self editClass. - editSelection := #newTrait. - self contentsChanged! Item was removed: - ----- Method: Browser>>noCommentNagString (in category 'class comment pane') ----- - noCommentNagString - - ^ Text - string: 'THIS CLASS HAS NO COMMENT!!' translated - attribute: (TextColor color: (self userInterfaceTheme noClassCommentColor ifNil: [Color red]))! Item was removed: - ----- Method: Browser>>noteSelectionIndex:for: (in category 'accessing') ----- - noteSelectionIndex: anInteger for: aSymbol - aSymbol == #systemCategoryList - ifTrue: - [self systemCategoryListIndex: anInteger]. - aSymbol == #classList - ifTrue: - [self classListIndex: anInteger]. - aSymbol == #messageCategoryList - ifTrue: - [self messageCategoryListIndex: anInteger]. - aSymbol == #messageList - ifTrue: - [self messageListIndex: anInteger].! Item was removed: - ----- Method: Browser>>okToClose (in category 'multi-window support') ----- - okToClose - ^super okToClose - and: [self multiWindowState isNil or: [self multiWindowState okToClose]]! Item was removed: - ----- Method: Browser>>packageMenu: (in category 'system category functions') ----- - packageMenu: aMenu - ^ self menu: aMenu for: #(packageMenu packageMenuShifted:) - ! Item was removed: - ----- Method: Browser>>plusButtonHit (in category 'class functions') ----- - plusButtonHit - "Cycle among definition, comment, and hierachy" - - editSelection == #editComment ifTrue: [ - self hierarchy. - self decorateButtons. - ^ self]. - - editSelection == #hierarchy ifTrue: [ - self editSelection: #editClass. - (self hasClassSelected and: [self okToChange]) ifTrue: [ - self changed: #editComment. - self contentsChanged]. - self decorateButtons. - ^ self]. - - self editComment. - self decorateButtons.! Item was removed: - ----- Method: Browser>>printOutClass (in category 'class functions') ----- - printOutClass - "Print a description of the selected class onto a file whose name is the - category name followed by .html." - - Cursor write showWhile: - [self hasClassSelected ifTrue: [self selectedClass fileOutAsHtml: true]]! Item was removed: - ----- Method: Browser>>printOutMessageCategories (in category 'message category functions') ----- - printOutMessageCategories - "Print a description of the selected message category of the selected class - onto an external file in Html format." - - Cursor write showWhile: - [self hasMessageCategorySelected - ifTrue: - [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName - asHtml: true]]! Item was removed: - ----- Method: Browser>>printOutSystemCategory (in category 'system category functions') ----- - printOutSystemCategory - "Print a description of each class in the selected category as Html." - - Cursor write showWhile: - [self hasSystemCategorySelected - ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategory - asHtml: true ]] - ! Item was removed: - ----- Method: Browser>>rawMessageCategoryList (in category 'message category list') ----- - rawMessageCategoryList - ^ self hasClassSelected - ifTrue: [self classOrMetaClassOrganizer categories] - ifFalse: [Array new]! Item was removed: - ----- Method: Browser>>recategorizeMethodSelector: (in category 'message category list') ----- - recategorizeMethodSelector: sel - "Categorize method named sel by looking in parent classes for a - method category. - Answer true if recategorized." - self selectedClassOrMetaClass allSuperclasses - do: [:ea | - | thisCat | - thisCat := ea organization categoryOfElement: sel. - (thisCat ~= ClassOrganizer default - and: [thisCat notNil]) - ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat logged: true. - self changed: #messageCategoryList. - ^ true]]. - ^ false! Item was removed: - ----- Method: Browser>>recent (in category 'class list') ----- - recent - "Let the user select from a list of recently visited classes" - - | className class recentList | - recentList := self recentClassList. - recentList size = 0 ifTrue: [^ Beeper beep]. - className := UIManager default chooseFrom: recentList values: recentList. - className == nil ifTrue: [^ self]. - - self okToChange ifFalse: [^ self]. - - class := Smalltalk at: className. - self selectCategoryForClass: class. - self classListIndex: (self classListIndexOf: class name)! Item was removed: - ----- Method: Browser>>recentClassList (in category 'class list') ----- - recentClassList - - ^ RecentClasses - select: [:className | className ~= self selectedClassName and: [Smalltalk hasClassNamed: className]]! Item was removed: - ----- Method: Browser>>recentClassListFormatted (in category 'class list') ----- - recentClassListFormatted - - ^ self recentClassList collect: [:className | - className asText - addAttribute: TextEmphasis italic; - yourself]! Item was removed: - ----- Method: Browser>>reformulateList (in category 'message list') ----- - reformulateList - "If the receiver has a way of reformulating its message list, here is a chance for it to do so" - super reformulateList. - (self messageList includes: self selectedMessageName) - ifFalse: [ self messageList - ifEmpty: [ self selectMessageNamed: nil ] - ifNotEmpty: [ self selectMessageNamed: self lastMessageName ]].! Item was removed: - ----- Method: Browser>>removeClass (in category 'class functions') ----- - removeClass - "Overwritten to update the class list." - - self hasClassSelected ifFalse: [^ false]. - super removeClass ifFalse: [^ false]. - - self classListIndex: 0. - self changed: #classList. - - ^ true! Item was removed: - ----- Method: Browser>>removeEmptyCategories (in category 'message category functions') ----- - removeEmptyCategories - self okToChange ifFalse: [^ self]. - self selectedClassOrMetaClass organization removeEmptyCategories. - self changed: #messageCategoryList - ! Item was removed: - ----- Method: Browser>>removeMessage (in category 'message functions') ----- - removeMessage - "Overwritten to update the message list." - - self hasMessageSelected ifFalse: [^ false]. - super removeMessage ifFalse: [^ false]. - - self selectMessageNamed: nil. - self changed: #messageList. - - self setClassOrganizer. "In case organization not cached" - - ^ true! Item was removed: - ----- Method: Browser>>removeMessageCategory (in category 'message category functions') ----- - removeMessageCategory - "Overwritten to update the message category list." - - self hasMessageCategorySelected ifFalse: [^ false]. - super removeMessageCategory ifFalse: [^ false]. - - self selectMessageCategoryNamed: nil. - self changed: #classSelectionChanged. "mt: Obsolete?" - self changed: #messageCategoryList. - - ^ true! Item was removed: - ----- Method: Browser>>removeMessageFromBrowser (in category 'message functions') ----- - removeMessageFromBrowser - "Our list speaks the truth and can't have arbitrary things removed" - - ^ self changed: #flash! Item was removed: - ----- Method: Browser>>removeSystemCategory (in category 'system category functions') ----- - removeSystemCategory - "Overwritten to update system category list." - - | nextSelectedCategory | - self hasSystemCategorySelected ifFalse: [^ false]. - - nextSelectedCategory := self systemCategoryList after: self selectedSystemCategory ifAbsent: [nil]. - super removeSystemCategory ifFalse: [^ false]. - - self changed: #systemCategoryList. - self selectSystemCategory: nextSelectedCategory. - - ^ true! Item was removed: - ----- Method: Browser>>renameCategory (in category 'message category functions') ----- - renameCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - | oldName newName | - self hasClassSelected ifFalse: [^ self]. - self okToChange ifFalse: [^ self]. - self hasMessageCategorySelected ifFalse: [^ self]. - - oldName := self selectedMessageCategoryName. - newName := self - request: 'Please type new category name' - initialAnswer: oldName. - newName isEmpty - ifTrue: [^ self] - ifFalse: [newName := newName asSymbol]. - newName = oldName ifTrue: [^ self]. - self classOrMetaClassOrganizer - renameCategory: oldName - toBe: newName. - self selectClassNamed: selectedClassName. - self selectMessageCategoryNamed: newName. - self changed: #messageCategoryList. - ! Item was removed: - ----- Method: Browser>>renameClass (in category 'class functions') ----- - renameClass - | oldName newName obs oldBinding | - self hasClassSelected ifFalse: [^ self]. - self okToChange - ifFalse: [^ self]. - oldName := self selectedClass name. - newName := self request: 'Please type new class name' initialAnswer: oldName. - newName = '' - ifTrue: [^ self]. - "Cancel returns ''" - newName := newName asSymbol. - newName = oldName - ifTrue: [^ self]. - (self selectedClass environment includesKey: newName) - ifTrue: [^ self error: newName , ' already exists']. - oldBinding := self selectedClass environment declarationOf: oldName. - [self selectedClass rename: newName] - on: RemarkNotification - do: [:ex | self inform: ex messageText. ex resume]. - selectedClassName := newName. - self changed: #classList. - obs := self systemNavigation allCallsOn: oldBinding. - obs isEmpty - ifFalse: [self systemNavigation - browseMessageList: obs - name: 'Obsolete References to ' , oldName - autoSelect: oldName]. - self selectClassNamed: newName.! Item was removed: - ----- Method: Browser>>renameSystemCategory (in category 'system category functions') ----- - renameSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - | oldSelection newName | - oldSelection := self selectedSystemCategory. - oldSelection isNil - ifTrue: [^ self]. "no selection" - self okToChange ifFalse: [^ self]. - - newName := self - request: 'Please type new category name' - initialAnswer: oldSelection. - newName isEmpty - ifTrue: [^ self] - ifFalse: [newName := newName asSymbol]. - oldSelection = newName ifTrue: [^ self]. - systemOrganizer - renameCategory: oldSelection - toBe: newName. - self selectSystemCategory: newName. - self changed: #systemCategoryList.! Item was removed: - ----- Method: Browser>>representsSameBrowseeAs: (in category 'morphic ui') ----- - representsSameBrowseeAs: anotherBrowser - - ^ self hasUnacceptedEdits not - and: [self selectedClass == anotherBrowser selectedClass] - and: [anotherBrowser selectedMessageName isNil - or: [anotherBrowser selectedMessageName = self selectedMessageName]]! Item was removed: - ----- Method: Browser>>request:initialAnswer: (in category 'accessing') ----- - request: prompt initialAnswer: initialAnswer - - ^ UIManager default - request: prompt - initialAnswer: initialAnswer - ! Item was removed: - ----- Method: Browser>>restoreMultiWindowState: (in category 'multi-window support') ----- - restoreMultiWindowState: aMessage - "Restore the state after a multi-window switch.." - aMessage sentTo: self! Item was removed: - ----- Method: Browser>>restoreToCategory:className:protocol:selector:mode:meta: (in category 'multi-window support') ----- - restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool - selectedSystemCategory := nil. "forces recomputation in selectSystemCategory:" - self selectSystemCategory: category. - self selectClassNamed: className. - self metaClassIndicated: metaBool. - self selectMessageCategoryNamed: protocol. - self selectMessageNamed: selector. - editSelection := editMode. - self - contentsChanged; - decorateButtons! Item was removed: - ----- Method: Browser>>saveMultiWindowState (in category 'multi-window support') ----- - saveMultiWindowState - ^Message - selector: #restoreToCategory:className:protocol:selector:mode:meta: - arguments: { self selectedSystemCategory. - self selectedClassName. - self selectedMessageCategoryName. - self selectedMessageName. - self editSelection. - self metaClassIndicated }! Item was removed: - ----- Method: Browser>>selectCategoryForClass: (in category 'system category list') ----- - selectCategoryForClass: theClass - self selectSystemCategory: theClass category.! Item was removed: - ----- Method: Browser>>selectClass: (in category 'class list') ----- - selectClass: classNotMeta - ^ self selectClassNamed: - (classNotMeta - ifNil: [ nil ] - ifNotNil: [ classNotMeta name ]).! Item was removed: - ----- Method: Browser>>selectClassNamed: (in category 'class list') ----- - selectClassNamed: aSymbolOrString - | className currentMessageCategoryName currentMessageName | - - currentMessageCategoryName := [self selectedMessageCategoryName] - on: Error - do: [:ex| ex return: nil]. - currentMessageName := [self selectedMessageName] - on: Error - do: [:ex| ex return: nil]. - - selectedClassName := aSymbolOrString ifNotNil: [ aSymbolOrString asSymbol ]. - self setClassOrganizer. - self setClassDefinition. - - "Try to reselect the category and/or selector if the new class has them." - selectedMessageCategoryName :=(self messageCategoryList includes: currentMessageCategoryName) - ifTrue: [currentMessageCategoryName] - ifFalse: [nil]. - selectedMessageName := (self messageList includes: currentMessageName) - ifTrue: [currentMessageName] - ifFalse: [nil]. - - self hasMessageSelected ifTrue: - [self editSelection: #editMessage] ifFalse: - [self hasMessageCategorySelected ifTrue: - [self editSelection: #newMessage] ifFalse: - [self classCommentIndicated - ifTrue: [self editSelection: #editComment] - ifFalse: [self editSelection: (self hasClassSelected not - ifTrue: [(metaClassIndicated or: [ self hasSystemCategorySelected not ]) - ifTrue: [#none] - ifFalse: [#newClass]] - ifFalse: [#editClass])]]]. - contents := nil. - self selectedClass isNil - ifFalse: [className := self selectedClass name. - (RecentClasses includes: className) - ifTrue: [RecentClasses remove: className]. - RecentClasses addFirst: className. - RecentClasses size > 16 - ifTrue: [RecentClasses removeLast]]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self changed: #selectedSystemCategoryName. - self contentsChanged! Item was removed: - ----- Method: Browser>>selectEnvironment: (in category 'accessing') ----- - selectEnvironment: anEnvironment - environment := anEnvironment. - systemOrganizer := environment organization! Item was removed: - ----- Method: Browser>>selectMessageCategoryNamed: (in category 'message category list') ----- - selectMessageCategoryNamed: aSymbol - "Given aSymbol, select the category with that name. Do nothing if - aSymbol doesn't exist." - - selectedMessageCategoryName := aSymbol. - selectedMessageName := nil. - - self changed: #messageCategorySelectionChanged. - self changed: #messageCategoryListIndex. "update my selection" - self changed: #messageList. - self changed: #messageListIndex. - - self editSelection: (aSymbol notNil - ifTrue: [#newMessage] - ifFalse: [self hasClassSelected - ifTrue: [#editClass] - ifFalse: [#newClass]]). - contents := nil. - self contentsChanged.! Item was removed: - ----- Method: Browser>>selectMessageNamed: (in category 'message list') ----- - selectMessageNamed: aSymbolOrString - | name | - name := aSymbolOrString ifNotNil: [ aSymbolOrString asSymbol ]. - selectedMessageName := name. - - self editSelection: (name notNil - ifTrue: [#editMessage] - ifFalse: [self messageCategoryListIndex > 0 - ifTrue: [#newMessage] - ifFalse: [self hasClassSelected - ifTrue: [#editClass] - ifFalse: [#newClass]]]). - contents := nil. - self changed: #messageListIndex. "update my selection" - self contentsChanged. - self decorateButtons.! Item was removed: - ----- Method: Browser>>selectSystemCategory: (in category 'system category list') ----- - selectSystemCategory: aSymbol - "Set the selected system category. Update all other selections to be deselected." - aSymbol = selectedSystemCategory ifTrue: [^ self]. - selectedSystemCategory := aSymbol. - selectedClassName := nil. - selectedMessageCategoryName := nil. - selectedMessageName := nil. - self editSelection: ( aSymbol isNil ifTrue: [#none] ifFalse: [#newClass]). - self metaClassIndicated: false. - self setClassOrganizer. - contents := nil. - - self - changed: #systemCategorySelectionChanged; - changed: #systemCategoryListIndex; "update my selection" - changed: #classList; - changed: #messageCategoryList; - changed: #messageList; - changed: #relabel. - - self - decorateButtons; - contentsChanged! Item was removed: - ----- Method: Browser>>selectedClass (in category 'class list') ----- - selectedClass - "Answer the class that is currently selected. Answer nil if no selection - exists." - - | name envt | - (name := self selectedClassName) ifNil: [^ nil]. - (envt := self selectedEnvironment) ifNil: [^ nil]. - ^ envt at: name ifAbsent: [envt valueOf: name ifAbsent: [nil]]! Item was removed: - ----- Method: Browser>>selectedClassName (in category 'class list') ----- - selectedClassName - ^ selectedClassName.! Item was removed: - ----- Method: Browser>>selectedClassOrMetaClass (in category 'metaclass') ----- - selectedClassOrMetaClass - "Answer the selected class/trait or metaclass/classTrait." - - | cls | - ^self metaClassIndicated - ifTrue: [(cls := self selectedClass) ifNil: [nil] ifNotNil: [cls classSide]] - ifFalse: [self selectedClass]! Item was removed: - ----- Method: Browser>>selectedClassOrMetaClassName (in category 'metaclass') ----- - selectedClassOrMetaClassName - "Answer the selected class name or metaclass name." - - ^self selectedClassOrMetaClass name! Item was removed: - ----- Method: Browser>>selectedEnvironment (in category 'system category list') ----- - selectedEnvironment - "Answer the browsed environment. If this returned a system category dependent - value and possibly nil (as it did in previous versions), selectedClass would not work in - a hierarchy browser that has to display classes from different environments - (because the correct categories might be missing in the browser)" - - ^ environment ifNil: [Smalltalk globals]! Item was removed: - ----- Method: Browser>>selectedMessage (in category 'message list') ----- - selectedMessage - "Answer a copy of the source code for the selected message." - - | class selector method | - contents == nil ifFalse: [^ contents copy]. - - self showingDecompile ifTrue: - [^ self decompiledSourceIntoContents]. - - class := self selectedClassOrMetaClass. - selector := self selectedMessageName. - method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" - currentCompiledMethod := method. - - ^ contents := (self showingDocumentation - ifFalse: [ self sourceStringPrettifiedAndDiffed ] - ifTrue: [ self commentContents ]) - copy asText makeSelectorBoldIn: class! Item was removed: - ----- Method: Browser>>selectedMessageCategoryName (in category 'message category list') ----- - selectedMessageCategoryName - "Answer the name of the selected message category, if any. Answer nil - otherwise." - - ^ selectedMessageCategoryName! Item was removed: - ----- Method: Browser>>selectedMessageName (in category 'message list') ----- - selectedMessageName - "Answer the message selector of the currently selected message, if any. - Answer nil otherwise." - - ^ selectedMessageName.! Item was removed: - ----- Method: Browser>>selectedMessageName: (in category 'message list') ----- - selectedMessageName: aSelector - "Make the given selector be the selected message name" - - | anIndex | - anIndex := self messageList indexOf: aSelector. - anIndex > 0 ifTrue: - [self messageListIndex: anIndex]. - self changed: #selectedMessageName. "inform interested parties"! Item was removed: - ----- Method: Browser>>selectedPackage (in category 'system category list') ----- - selectedPackage - - ^ self environment packageOrganizer - packageOfSystemCategory: self selectedSystemCategory - ifNone: []! Item was removed: - ----- Method: Browser>>selectedSystemCategory (in category 'system category list') ----- - selectedSystemCategory - ^ selectedSystemCategory! Item was removed: - ----- Method: Browser>>selectedSystemCategoryName (in category 'system category list') ----- - selectedSystemCategoryName - "Answer the name of the selected system category or nil." - - ^ self selectedSystemCategory.! Item was removed: - ----- Method: Browser>>setClass: (in category 'initialize-release') ----- - setClass: aBehavior - "Set the state of a new, uninitialized Browser." - - | isMeta aClass | - aBehavior ifNil: [^ self]. - aBehavior isMeta - ifTrue: [ - isMeta := true. - aClass := aBehavior soleInstance] - ifFalse: [ - isMeta := false. - aClass := aBehavior]. - - self - selectEnvironment: aClass environment; - selectCategoryForClass: aClass; - classListIndex: (self classListIndexOf: aClass name); - metaClassIndicated: isMeta.! Item was removed: - ----- Method: Browser>>setClass:selector: (in category 'initialize-release') ----- - setClass: aBehavior selector: aSymbol - "Set the state of a new, uninitialized Browser." - - aBehavior ifNil: [^ self]. - - self - setClass: aBehavior; - setSelector: aSymbol.! Item was removed: - ----- Method: Browser>>setClassDefinition (in category 'metaclass') ----- - setClassDefinition - "Remember the current class definition." - - | theClass | - classDefinition := nil. - metaClassDefinition := nil. - self hasClassSelected ifFalse: [^ self]. - theClass := self selectedClass ifNil: [ ^self ]. - classDefinition := theClass definition. - metaClassDefinition := theClass theMetaClass definition.! Item was removed: - ----- Method: Browser>>setClassOrganizer (in category 'metaclass') ----- - setClassOrganizer - "Install whatever organization is appropriate" - | theClass | - classOrganizer := nil. - metaClassOrganizer := nil. - self hasClassSelected ifFalse: [^ self]. - theClass := self selectedClass ifNil: [ ^self ]. - classOrganizer := theClass organization. - metaClassOrganizer := theClass classSide organization.! Item was removed: - ----- Method: Browser>>setMultiWindowFor: (in category 'toolbuilder') ----- - setMultiWindowFor: windowSpec - "set the multi-window style for the windowSpec according to both the users preference and the browser's ability" - (self class canUseMultiWindowBrowsers and: [self class useMultiWindowBrowsers]) - ifTrue: [windowSpec multiWindowStyle: #labelButton]. - - ! Item was removed: - ----- Method: Browser>>setOriginalCategoryIndexForCurrentMethod (in category 'message category list') ----- - setOriginalCategoryIndexForCurrentMethod - "private - Set the message category index for the currently selected method. - - Note: This should only be called when somebody tries to save - a method that they are modifying while ALL is selected." - - selectedMessageCategoryName := self categoryOfCurrentMethod.! Item was removed: - ----- Method: Browser>>setSelector: (in category 'initialize-release') ----- - setSelector: aSymbol - "Make the receiver point at the given selector, in the currently chosen class. If the selector is found in the class organization we also set the message category to suit" - - | aClass | - aSymbol ifNil: [^ self]. - (aClass := self selectedClassOrMetaClass) ifNil: [^ self]. - (aClass organization categoryOfElement: aSymbol) - ifNil: [^ self] - ifNotNil: [:category | - self - selectMessageCategoryNamed: category; - selectMessageNamed: aSymbol].! Item was removed: - ----- Method: Browser>>shiftedClassListMenu: (in category 'class functions') ----- - shiftedClassListMenu: aMenu - <classListMenuShifted: true> - "Set up the menu to apply to the receiver's class list when the shift key is down" - ^ aMenu - addList: #( - - - ('local senders...' browseLocalSenders 'browse senders local to this class') - ('unsent methods' browseUnusedMethods 'browse all methods defined by this class that have no senders') - ('unreferenced inst vars' showUnreferencedInstVars 'show a list of all instance variables that are not referenced in methods') - ('unreferenced class vars' showUnreferencedClassVars 'show a list of all class variables that are not referenced in methods') - ('subclass template' makeNewSubclass 'put a template into the code pane for defining of a subclass of this class') - - - ('sample instance' makeSampleInstance 'give me a sample instance of this class, if possible') - ('inspect instances' inspectInstances 'open an inspector on all the extant instances of this class') - ('inspect subinstances' inspectSubInstances 'open an inspector on all the extant instances of this class and of all of its subclasses') - - - ('add all meths to current chgs' addAllMethodsToCurrentChangeSet - 'place all the methods defined by this class into the current change set') - ('create inst var accessors' createInstVarAccessors 'compile instance-variable access methods for any instance variables that do not yet have them')); - yourself! Item was removed: - ----- Method: Browser>>shiftedClassListMenuMore: (in category 'class functions') ----- - shiftedClassListMenuMore: aMenu - " The 'more..' link that toggles between unshifted and shifted menus - in class lists " - <classListMenuShifted: true> - <menuPriority: 1000> - ^ aMenu addList: #(- - ('more...' offerUnshiftedClassListMenu 'return to the standard class-list menu')); - yourself! Item was removed: - ----- Method: Browser>>shiftedMessageListMenu: (in category 'message list') ----- - shiftedMessageListMenu: aMenu - <messageListMenuShifted: true> - "Fill aMenu with the items appropriate when the shift key is held down" - - aMenu addStayUpItem. - aMenu addList: #( - ('toggle diffing (D)' toggleDiffing) - ('implementors of sent messages' browseAllMessages) - - - ('local senders of...' browseLocalSendersOfMessages) - ('local implementors of...' browseLocalImplementors) - - - ('spawn sub-protocol' spawnProtocol) - ('spawn full protocol' spawnFullProtocol) - - - ('sample instance' makeSampleInstance) - ('inspect instances' inspectInstances) - ('inspect subinstances' inspectSubInstances)). - - self addExtraShiftedItemsTo: aMenu. - aMenu addList: #( - - - ('change category...' changeCategory)). - - self canShowMultipleMessageCategories ifTrue: [aMenu addList: - #(('toggle category selection (Y)' showHomeCategory))]. - aMenu addList: #( - - - ('change sets with this method' findMethodInChangeSets) - ('revert to previous version' revertToPreviousVersion) - ('remove from current change set' removeFromCurrentChanges) - ('revert & remove from changes' revertAndForget) - ('add to current change set' adoptMessageInCurrentChangeset) - ('copy up or copy down...' copyUpOrCopyDown)). - ^ aMenu - ! Item was removed: - ----- Method: Browser>>showBytecodes (in category 'code pane') ----- - showBytecodes - "Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant." - - self toggleShowingByteCodes! Item was removed: - ----- Method: Browser>>showHomeCategory (in category 'message category functions') ----- - showHomeCategory - "Select the category of the currently-selected method. If it is already selected, or if no method is selected, deselect it to unfilter the message list." - self okToChange ifTrue: - [ | aSelector | ((aSelector := self selectedMessageName) notNil or: [ selectedMessageCategoryName notNil ]) ifTrue: - [ aSelector - ifNil: [ self selectMessageCategoryNamed: nil ] - ifNotNil: [ self toggleCategorySelectionForCurrentMethod ]. - self selectedMessageName: aSelector ] ]! Item was removed: - ----- Method: Browser>>spawn: (in category 'accessing') ----- - spawn: aString - "Create and schedule a fresh browser and place aString in its code pane. This method is called when the user issues the #spawn command (cmd-o) in any code pane. Whatever text was in the original code pane comes in to this method as the aString argument; the changes in the original code pane have already been cancelled by the time this method is called, so aString is the only copy of what the user had in his code pane." - - self selectedClassOrMetaClass ifNotNil: [^ super spawn: aString]. - - self hasSystemCategorySelected ifTrue: - ["Open a browser with the initial codepane string set" - ^ self buildSystemCategoryBrowserEditString: aString]. - - ^ super spawn: aString - "This bail-out at least saves the text being spawned, which would otherwise be lost"! Item was removed: - ----- Method: Browser>>spawnOrNavigateTo: (in category 'private') ----- - spawnOrNavigateTo: aClass - self setClass: aClass selector: nil! Item was removed: - ----- Method: Browser>>stripNaggingAttributeFromComment: (in category 'class comment pane') ----- - stripNaggingAttributeFromComment: aText - ^aText removeAttribute: TextColor red from: 1 to: aText size! Item was removed: - ----- Method: Browser>>suggestCategoryToSpawnedBrowser: (in category 'accessing') ----- - suggestCategoryToSpawnedBrowser: aBrowser - "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." - - (self isMemberOf: Browser) "yecch, but I didn't invent the browser hierarchy" - ifTrue: - [aBrowser messageCategoryListIndex: (self messageCategoryList indexOf: self categoryOfCurrentMethod ifAbsent: [2])] - ifFalse: - [aBrowser setOriginalCategoryIndexForCurrentMethod]! Item was removed: - ----- Method: Browser>>switchesFrame: (in category 'initialize-release') ----- - switchesFrame: bottomFraction - ^self switchesFrame: bottomFraction fromLeft: 0.25 width: 0.25.! Item was removed: - ----- Method: Browser>>switchesFrame:fromLeft:width: (in category 'initialize-release') ----- - switchesFrame: bottomFraction fromLeft: leftFraction width: rightFraction - ^LayoutFrame new - leftFraction: leftFraction offset: 0; - topFraction: bottomFraction offset: self buttonHeight negated; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: bottomFraction offset: 0! Item was removed: - ----- Method: Browser>>systemCatListKey:from: (in category 'system category list') ----- - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [^ self findClass]. - aChar == $x ifTrue: [^ self removeSystemCategory]. - aChar == $b ifTrue: [^ self recent]. - ^ self classListKey: aChar from: view! Item was removed: - ----- Method: Browser>>systemCatSingletonKey:from: (in category 'initialize-release') ----- - systemCatSingletonKey: aChar from: aView - ^ self messageListKey: aChar from: aView! Item was removed: - ----- Method: Browser>>systemCatSingletonMenu: (in category 'system category functions') ----- - systemCatSingletonMenu: aMenu - - ^ aMenu labels: - 'browse all - browse - printOut - fileOut - update - rename... - remove' - lines: #(2 4) - selections: - #(browseAllClasses buildSystemCategoryBrowser - printOutSystemCategory fileOutSystemCategory updateSystemCategories - renameSystemCategory removeSystemCategory) - ! Item was removed: - ----- Method: Browser>>systemCategoryList (in category 'system category list') ----- - systemCategoryList - "Answer the class categories modelled by the receiver." - - ^ {SystemOrganizer allCategory}, systemOrganizer categories! Item was removed: - ----- Method: Browser>>systemCategoryListIndex (in category 'system category list') ----- - systemCategoryListIndex - "Answer the index of the selected class category." - - ^ self systemCategoryList indexOf: self selectedSystemCategory.! Item was removed: - ----- Method: Browser>>systemCategoryListIndex: (in category 'system category list') ----- - systemCategoryListIndex: anInteger - "Set the selected system category index to be anInteger. Update all other - selections to be deselected." - - self selectSystemCategory: (self systemCategoryList at: anInteger ifAbsent: [ nil ])! Item was removed: - ----- Method: Browser>>systemCategoryMenu: (in category 'system category functions') ----- - systemCategoryMenu: aMenu - ^ self menu: aMenu for: #(systemCategoryMenu systemCategoryMenuShifted:) - ! Item was removed: - ----- Method: Browser>>systemCategoryMenuHook:shifted: (in category 'pluggable menus - hooks') ----- - systemCategoryMenuHook: aMenu shifted: aBoolean - <systemCategoryMenu> - <menuPriority: 400> - ^ self menuHook: aMenu named: #systemCategoryMenu shifted: aBoolean. - ! Item was removed: - ----- Method: Browser>>systemCategorySingleton (in category 'system category list') ----- - systemCategorySingleton - - | cat | - cat := self selectedSystemCategory. - ^ cat ifNil: [Array new] - ifNotNil: [Array with: cat]! Item was removed: - ----- Method: Browser>>systemOrganizer (in category 'accessing') ----- - systemOrganizer - - ^ systemOrganizer! Item was removed: - ----- Method: Browser>>systemOrganizer: (in category 'initialize-release') ----- - systemOrganizer: aSystemOrganizer - "Initialize the receiver as a perspective on the system organizer, - aSystemOrganizer. Typically there is only one--the system variable - SystemOrganization." - - contents := nil. - systemOrganizer := aSystemOrganizer. - selectedSystemCategory := nil. - selectedMessageCategoryName := nil. - selectedClassName := nil. - selectedMessageName := nil. - metaClassIndicated := false. - self setClassOrganizer. - self editSelection: #none.! Item was removed: - ----- Method: Browser>>toggleCategorySelectionForCurrentMethod (in category 'message category list') ----- - toggleCategorySelectionForCurrentMethod - | methodCategory selectorName | - methodCategory := self categoryOfCurrentMethod. - selectorName := self selectedMessageName. - (methodCategory notNil and: - [ methodCategory ~= ClassOrganizer allCategory and: [ methodCategory ~= selectedMessageCategoryName ] ]) - ifTrue: - [ selectedMessageCategoryName := methodCategory. - selectedMessageName := selectorName. - self changed: #messageCategorySelectionChanged. - self changed: #messageCategoryListIndex. - "update my selection" - self changed: #messageList. - self changed: #messageListIndex ] - ifFalse: - [ methodCategory = selectedMessageCategoryName ifTrue: - [ selectedMessageCategoryName := nil. - self - changed: #messageCategorySelectionChanged ; - changed: #messageCategoryListIndex ; - changed: #messageList ] ]! Item was removed: - ----- Method: Browser>>topConstantHeightFrame:fromLeft:width: (in category 'initialize-release') ----- - topConstantHeightFrame: height fromLeft: leftFraction width: rightFraction - ^LayoutFrame new - topFraction: 0 offset: 0; - leftFraction: leftFraction offset: 0; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: 0 offset: height; - yourself.! Item was removed: - ----- Method: Browser>>traitsMenu: (in category 'traits') ----- - traitsMenu: aMenu - <classListMenuShifted: false> - <menuPriority: 140> - - self selectedClass isTrait ifTrue: [ - aMenu add: 'browse trait users' action: #browseTraitUsers]. - ^ aMenu! Item was removed: - ----- Method: Browser>>updateCodePaneIfNeeded (in category 'self-updating') ----- - updateCodePaneIfNeeded - - super updateCodePaneIfNeeded. - - (self didCodeChangeElsewhere and: [self hasUnacceptedEdits not]) - ifTrue: - [self setClassDefinition. - self contentsChanged].! Item was removed: - ----- Method: Browser>>updateSystemCategories (in category 'system category functions') ----- - updateSystemCategories - "The class categories were changed in another browser. The receiver must - reorganize its lists based on these changes." - - self okToChange ifFalse: [^ self]. - self changed: #systemCategoryList! Item was removed: - ----- Method: Browser>>veryDeepInner: (in category 'copying') ----- - veryDeepInner: deepCopier - "Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment." - - super veryDeepInner: deepCopier. - "systemOrganizer := systemOrganizer. clone has the old value. we share it" - "classOrganizer := classOrganizer clone has the old value. we share it" - "metaClassOrganizer := metaClassOrganizer clone has the old value. we share it" - selectedSystemCategory := selectedSystemCategory veryDeepCopyWith: deepCopier. - selectedClassName := selectedClassName veryDeepCopyWith: deepCopier. - selectedMessageCategoryName := selectedMessageCategoryName veryDeepCopyWith: deepCopier. - selectedMessageName := selectedMessageName veryDeepCopyWith: deepCopier. - editSelection := editSelection veryDeepCopyWith: deepCopier. - metaClassIndicated := metaClassIndicated veryDeepCopyWith: deepCopier. - ! Item was removed: - ----- Method: Browser>>wantsMessageCategoriesDrop: (in category 'drag and drop') ----- - wantsMessageCategoriesDrop: anObject - "Only accept drops of compiled methods on system categories" - ^anObject isKindOf: CompiledMethod! Item was removed: - ----- Method: Browser>>wantsSystemCategoriesDrop: (in category 'drag and drop') ----- - wantsSystemCategoriesDrop: anObject - "Only accept drops of behaviors on system categories" - ^anObject isBehavior! Item was removed: - PluggableTextMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !BrowserCommentTextMorph commentStamp: '<historical>' prior: 0! - I am a PluggableTextMorph that knows enough to make myself invisible when necessary.! Item was removed: - ----- Method: BrowserCommentTextMorph>>hideOrShowPane (in category 'displaying') ----- - hideOrShowPane - (self model editSelection == #editClass) - ifTrue: [ self showPane ] - ifFalse: [ self hidePane ]! Item was removed: - ----- Method: BrowserCommentTextMorph>>hidePane (in category 'displaying') ----- - hidePane - | win | - self window ifNotNil: [:window | window removePaneSplitters]. - - self lowerPane ifNotNil: - [ :lp | - lp layoutFrame bottomFraction: self layoutFrame bottomFraction. - lp layoutFrame bottomOffset: SystemWindow borderWidth negated]. - win := self window ifNil: [ ^self ]. - self delete. - win updatePanesFromSubmorphs. - win addPaneSplitters! Item was removed: - ----- Method: BrowserCommentTextMorph>>lowerPane (in category 'accessing') ----- - lowerPane - "Answer the AlignmentMorph that I live beneath" - ^self valueOfProperty: #browserLowerPane! Item was removed: - ----- Method: BrowserCommentTextMorph>>noteNewOwner: (in category 'updating') ----- - noteNewOwner: win - super noteNewOwner: win. - self setProperty: #browserWindow toValue: win. - win ifNil: [ ^self ]. - win setProperty: #browserClassCommentPane toValue: self. - self setProperty: #browserLowerPane - toValue: (win submorphThat: [ :m | - m isAlignmentMorph - and: [ m layoutFrame bottomFraction notNil - and: [ m layoutFrame bottomFraction >= self layoutFrame topFraction ]]] - ifNone: [])! Item was removed: - ----- Method: BrowserCommentTextMorph>>showPane (in category 'displaying') ----- - showPane - owner ifNil: [ - | win | - win := self window ifNil: [ ^self ]. - win addMorph: self fullFrame: self layoutFrame. - win updatePanesFromSubmorphs ]. - - self lowerPane ifNotNil: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ]. - - self window ifNotNil: [:win | win addPaneSplitters]! Item was removed: - ----- Method: BrowserCommentTextMorph>>update: (in category 'updating') ----- - update: anAspect - super update: anAspect. - anAspect == #editSelection ifFalse: [ ^self ]. - self hideOrShowPane! Item was removed: - ----- Method: BrowserCommentTextMorph>>window (in category 'accessing') ----- - window - ^self owner ifNil: [ self valueOfProperty: #browserWindow ].! Item was removed: - ----- Method: ByteTextConverter class>>browseAllCodePoints (in category '*Tools-Browsing') ----- - browseAllCodePoints - " - MacRomanTextConverter browseAllCodePoints. - Latin1TextConverter browseAllCodePoints. - CP1252TextConverter browseAllCodePoints. - - MacLatin2TextConverter browseAllCodePoints. - Latin2TextConverter browseAllCodePoints. - - MacCyrillicTextConverter browseAllCodePoints. - - - " - self browseAllCodePointsUsing: TextStyle defaultFont.! Item was removed: - ----- Method: ByteTextConverter class>>browseAllCodePointsUsing: (in category '*Tools-Browsing') ----- - browseAllCodePointsUsing: aFont - "Apply the receivers encoding (code points 0 to 255) to browse the result using glyphs of aFont (and its #fallbackFont)." - - aFont - browseGlyphsOf: (Array streamContents: [:s | | | - self decodeTable withIndexDo: [:ea :i | | codePoint | - codePoint := ea = -1 - ifTrue: [ea] - ifFalse: [ea bitAnd: 16r1FFFFF "Drop language info / leadingChar"]. - codePoint := codePoint caseOf: { [-1] -> [32]. [9 "tab"] -> [32]. [10 "line break"] -> [32]. [13 "line break"] -> [32]. } otherwise: [codePoint]. - (i-1 \\ 16 = 0 and: [s position > 0]) ifTrue: [s cr]. - s tab; nextPut: codePoint]]) - label: self name, ' decoding table'.! Item was removed: - Model subclass: #CPUWatcher - instanceVariableNames: 'tally watcher threshold' - classVariableNames: 'CpuWatcherEnabled CurrentCPUWatcher' - poolDictionaries: '' - category: 'Tools-Process Browser'! - - !CPUWatcher commentStamp: '<historical>' prior: 0! - CPUWatcher implements a simple runaway process monitoring tool - that will suspend a process that is taking up too much of Squeak's - time and allow user interaction. By default it watches for a Process that - is taking more than 80% of the time; this threshold can be changed. - - CPUWatcher can also be used to show cpu percentages for each process - from within the ProcessBrowser. - - CPUWatcher startMonitoring. "process period 20 seconds, sample rate 100 msec" - CPUWatcher current monitorProcessPeriod: 10 sampleRate: 20. - CPUWatcher current threshold: 0.5. "change from 80% to 50%" - CPUWatcher stopMonitoring. - ! Item was removed: - ----- Method: CPUWatcher class>>cpuWatcherEnabled (in category 'preferences') ----- - cpuWatcherEnabled - <preference: 'CPU Watcher enabled' category: #('debug' 'performance') description: 'If true, Squeak will monitor processes for CPU usage. If any uses too much CPU, you will get a notification menu that will allow you to debug, resume or terminate the process.' type: #Boolean> - ^ CpuWatcherEnabled ifNil: [false].! Item was removed: - ----- Method: CPUWatcher class>>cpuWatcherEnabled: (in category 'preferences') ----- - cpuWatcherEnabled: aBoolean - CpuWatcherEnabled := aBoolean. - self monitorPreferenceChanged.! Item was removed: - ----- Method: CPUWatcher class>>current (in category 'singleton') ----- - current - ^CurrentCPUWatcher - ! Item was removed: - ----- Method: CPUWatcher class>>currentWatcherProcess (in category 'accessing') ----- - currentWatcherProcess - ^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ] - ! Item was removed: - ----- Method: CPUWatcher class>>dumpTallyOnTranscript (in category 'monitoring') ----- - dumpTallyOnTranscript - self current ifNotNil: [ - ProcessBrowser dumpTallyOnTranscript: self current tally - ]! Item was removed: - ----- Method: CPUWatcher class>>initialize (in category 'class initialization') ----- - initialize - "CPUWatcher initialize" - Smalltalk addToStartUpList: self. - Smalltalk addToShutDownList: self.! Item was removed: - ----- Method: CPUWatcher class>>isMonitoring (in category 'monitoring') ----- - isMonitoring - - ^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ] - ! Item was removed: - ----- Method: CPUWatcher class>>monitorPreferenceChanged (in category 'preferences') ----- - monitorPreferenceChanged - self cpuWatcherEnabled - ifTrue: [ self startMonitoring ] - ifFalse: [ self stopMonitoring ]! Item was removed: - ----- Method: CPUWatcher class>>shutDown (in category 'system startup') ----- - shutDown - self stopMonitoring.! Item was removed: - ----- Method: CPUWatcher class>>startMonitoring (in category 'monitoring') ----- - startMonitoring - "CPUWatcher startMonitoring" - - ^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! Item was removed: - ----- Method: CPUWatcher class>>startMonitoringPeriod:rate:threshold: (in category 'monitoring') ----- - startMonitoringPeriod: pd rate: rt threshold: th - "CPUWatcher startMonitoring" - - CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ]. - CurrentCPUWatcher := (self new) - monitorProcessPeriod: pd sampleRate: rt; - threshold: th; - yourself. - ^CurrentCPUWatcher - ! Item was removed: - ----- Method: CPUWatcher class>>startUp (in category 'system startup') ----- - startUp - self monitorPreferenceChanged.! Item was removed: - ----- Method: CPUWatcher class>>stopMonitoring (in category 'monitoring') ----- - stopMonitoring - "CPUWatcher stopMonitoring" - - CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ]. - CurrentCPUWatcher := nil. - ! Item was removed: - ----- Method: CPUWatcher>>catchThePig: (in category 'porcine capture') ----- - catchThePig: aProcess - | rules | - "nickname, allow-stop, allow-debug" - rules := ProcessBrowser nameAndRulesFor: aProcess. - - (ProcessBrowser isUIProcess: aProcess) - ifTrue: [ "aProcess debugWithTitle: 'Interrupted from the CPUWatcher'." ] - ifFalse: [ rules second ifFalse: [ ^self ]. - ProcessBrowser suspendProcess: aProcess. - self openWindowForSuspendedProcess: aProcess ] - ! Item was removed: - ----- Method: CPUWatcher>>debugProcess: (in category 'process operations') ----- - debugProcess: aProcess - | uiPriority oldPriority | - uiPriority := Processor activeProcess priority. - aProcess priority >= uiPriority ifTrue: [ - oldPriority := ProcessBrowser setProcess: aProcess toPriority: uiPriority - 1 - ]. - ProcessBrowser debugProcess: aProcess.! Item was removed: - ----- Method: CPUWatcher>>debugProcess:fromMenu: (in category 'process operations') ----- - debugProcess: aProcess fromMenu: aMenuMorph - aMenuMorph delete. - self debugProcess: aProcess.! Item was removed: - ----- Method: CPUWatcher>>findThePig (in category 'porcine capture') ----- - findThePig - "tally has been updated. Look at it to see if there is a bad process. - This runs at a very high priority, so make it fast" - | countAndProcess | - countAndProcess := tally sortedCounts first. - (countAndProcess key / tally size > self threshold) ifTrue: [ | proc | - proc := countAndProcess value. - proc == Processor backgroundProcess ifTrue: [ ^self ]. "idle process? OK" - self catchThePig: proc - ]. - ! Item was removed: - ----- Method: CPUWatcher>>isMonitoring (in category 'accessing') ----- - isMonitoring - ^watcher notNil! Item was removed: - ----- Method: CPUWatcher>>monitorProcessPeriod:sampleRate: (in category 'startup-shutdown') ----- - monitorProcessPeriod: secs sampleRate: msecs - self stopMonitoring. - - watcher := [ [ | promise | - promise := Processor tallyCPUUsageFor: secs every: msecs. - tally := promise value. - promise := nil. - self findThePig. - ] repeat ] forkAt: Processor highestPriority. - Processor yield ! Item was removed: - ----- Method: CPUWatcher>>openMVCWindowForSuspendedProcess: (in category 'porcine capture') ----- - openMVCWindowForSuspendedProcess: aProcess - ProcessBrowser open! Item was removed: - ----- Method: CPUWatcher>>openMorphicWindowForSuspendedProcess: (in category 'porcine capture') ----- - openMorphicWindowForSuspendedProcess: aProcess - | menu rules | - menu := MenuMorph new. - "nickname allow-stop allow-debug" - rules := ProcessBrowser nameAndRulesFor: aProcess. - menu add: 'Dismiss this menu' target: menu selector: #delete; addLine. - menu add: 'Open Process Browser' target: ProcessBrowser selector: #open. - menu add: 'Resume' - target: self - selector: #resumeProcess:fromMenu: - argumentList: { aProcess . menu }. - menu add: 'Terminate' - target: self - selector: #terminateProcess:fromMenu: - argumentList: { aProcess . menu }. - rules third ifTrue: [ - menu add: 'Debug at a lower priority' - target: self - selector: #debugProcess:fromMenu: - argumentList: { aProcess . menu }. - ]. - menu addTitle: aProcess identityHash asString, - ' ', rules first, - ' is taking too much time and has been suspended. - What do you want to do with it?'. - menu stayUp: true. - menu popUpInWorld - ! Item was removed: - ----- Method: CPUWatcher>>openWindowForSuspendedProcess: (in category 'porcine capture') ----- - openWindowForSuspendedProcess: aProcess - - Smalltalk isMorphic - ifTrue: [ WorldState addDeferredUIMessage: [ self openMorphicWindowForSuspendedProcess: aProcess ] ] - ifFalse: [ [ self openMVCWindowForSuspendedProcess: aProcess ] forkAt: Processor userSchedulingPriority ] - ! Item was removed: - ----- Method: CPUWatcher>>resumeProcess:fromMenu: (in category 'process operations') ----- - resumeProcess: aProcess fromMenu: aMenuMorph - aMenuMorph delete. - ProcessBrowser resumeProcess: aProcess.! Item was removed: - ----- Method: CPUWatcher>>startMonitoring (in category 'startup-shutdown') ----- - startMonitoring - self - monitorProcessPeriod: 20 sampleRate: 100! Item was removed: - ----- Method: CPUWatcher>>stopMonitoring (in category 'startup-shutdown') ----- - stopMonitoring - watcher ifNotNil: [ - ProcessBrowser terminateProcess: watcher. - watcher := nil. - ]! Item was removed: - ----- Method: CPUWatcher>>tally (in category 'accessing') ----- - tally - ^tally copy! Item was removed: - ----- Method: CPUWatcher>>terminateProcess:fromMenu: (in category 'process operations') ----- - terminateProcess: aProcess fromMenu: aMenuMorph - aMenuMorph delete. - ProcessBrowser terminateProcess: aProcess.! Item was removed: - ----- Method: CPUWatcher>>threshold (in category 'accessing') ----- - threshold - "What fraction of the time can a process be the active process before we stop it?" - ^threshold! Item was removed: - ----- Method: CPUWatcher>>threshold: (in category 'accessing') ----- - threshold: thresh - "What fraction of the time can a process be the active process before we stop it?" - threshold := (thresh max: 0.02) min: 1.0! Item was removed: - ----- Method: CPUWatcher>>watcherProcess (in category 'accessing') ----- - watcherProcess - ^watcher! Item was removed: - CodeHolder subclass: #ChangeList - instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer showsVersions' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - - !ChangeList commentStamp: '<historical>' prior: 0! - A ChangeList represents a list of changed methods that reside on a file in fileOut format. The classes and methods in my list are not necessarily in this image!! Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...). Note that the two kinds of window have different controller classes!!!! - - It holds three lists: - changeList - a list of ChangeRecords - list - a list of one-line printable headers - listSelections - a list of Booleans (true = selected, false = not selected) multiple OK. - listIndex - Items that are removed (removeDoits, remove an item) are removed from all three lists. - Most recently clicked item is the one showing in the bottom pane.! Item was removed: - ----- Method: ChangeList class>>browseChangesFile: (in category 'fileIn/Out') ----- - browseChangesFile: fullName - "Browse the selected file in fileIn format." - - fullName - ifNotNil: - [ChangeList browseStream: (FileStream readOnlyFileNamed: fullName)] - ifNil: - [Beeper beep]! Item was removed: - ----- Method: ChangeList class>>browseCompressedChangesFile: (in category 'fileIn/Out') ----- - browseCompressedChangesFile: fullName - "Browse the selected file in fileIn format." - - | unzipped | - fullName ifNil: [^Beeper beep]. - FileStream readOnlyFileNamed: fullName do: [:stream | - unzipped := (GZipReadStream on: stream) contents]. - ChangeList browseStream: (MultiByteBinaryOrTextStream with: unzipped asString)! Item was removed: - ----- Method: ChangeList class>>browseFile: (in category 'public access') ----- - browseFile: fileName "ChangeList browseFile: 'AutoDeclareFix.st'" - "Opens a changeList on the file named fileName" - - ^ self browseStream: (FileStream readOnlyFileNamed: fileName)! Item was removed: - ----- Method: ChangeList class>>browseMethodVersions (in category 'public access') ----- - browseMethodVersions - - | changeList end changesFile filteredRecords | - changesFile := (SourceFiles at: 2) readOnlyCopy. - end := changesFile size. - changeList := self new. - Cursor read showWhile: [ - changeList scanFile: changesFile from: 0 to: end]. - changesFile close. - - filteredRecords := Dictionary new. - changeList changeList - do: [:changeRecord | - changeRecord methodSelector ifNotNil: [:selector | - | class | - class := changeRecord methodClass. - "Only collect records that point to not-installed methods." - (class isNil or: [(class includesSelector: selector) not]) ifTrue: [ - (filteredRecords at: selector ifAbsentPut: [OrderedCollection new]) - add: changeRecord]]] - displayingProgress: [:changeRecord | 'Parsing source code at {1}...' translated format: {changeRecord position}]. - filteredRecords explore. "Open explorer to allow user to repeat the following step manually." - self browseMethodVersions: filteredRecords.! Item was removed: - ----- Method: ChangeList class>>browseMethodVersions: (in category 'public access') ----- - browseMethodVersions: filteredRecords - - | changeList sortedKeys choice | - sortedKeys := filteredRecords keys sorted. - choice := Project uiManager chooseFrom: sortedKeys values: sortedKeys title: 'Recover method versions' translated. - choice ifNil: [^ self]. - - "Only ChangeList can handle the mix of (maybe non-existing) class references in records. For example, VersionsBrowser is not supported." - changeList := ChangeList new. - - (filteredRecords at: choice) do: [:changeRecord | - changeList - addItem: changeRecord - text: ('{1} {2}{3}{4} \{{5}\}' format: { - changeRecord stamp. - changeRecord methodClassName. - changeRecord isMetaClassChange - ifTrue: [' class '] ifFalse: [' ']. - choice. - changeRecord category})]. - changeList resetListSelections. - - self - open: changeList - name: ('All local versions for {1}' translated format: {choice storeString}) - multiSelect: false! Item was removed: - ----- Method: ChangeList class>>browseRecent: (in category 'public access') ----- - browseRecent: charCount - "ChangeList browseRecent: 5000" - "Opens a changeList on the end of the changes log file" - ^ self browseRecent: charCount on: (SourceFiles at: 2) ! Item was removed: - ----- Method: ChangeList class>>browseRecent:on: (in category 'public access') ----- - browseRecent: charCount on: origChangesFile - "Opens a changeList on the end of the specified changes log file" - | changeList end changesFile | - changesFile := origChangesFile readOnlyCopy. - changesFile setConverterForCode. - end := changesFile size. - changeList := Cursor read - showWhile: [self new - scanFile: changesFile - from: (0 max: end - charCount) - to: end]. - changesFile close. - self - open: changeList - name: 'Recent changes' translated - multiSelect: true! Item was removed: - ----- Method: ChangeList class>>browseRecentLog (in category 'public access') ----- - browseRecentLog - "ChangeList browseRecentLog" - "Prompt with a menu of how far back to go to browse the current image's changes log file" - ^ self - browseRecentLogOn: (SourceFiles at: 2) - startingFrom: Smalltalk lastQuitLogPosition! Item was removed: - ----- Method: ChangeList class>>browseRecentLogOn: (in category 'public access') ----- - browseRecentLogOn: origChangesFile - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block pos chunk changesFile position prevBlock | - changesFile := origChangesFile readOnlyCopy. - position := nil. - end := changesFile size. - prevBlock := end. - block := end - 1024 max: 0. - done := false. - [done - or: [position notNil]] - whileFalse: [changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [changesFile position < prevBlock] - whileTrue: [pos := changesFile position. - chunk := changesFile nextChunk. - ((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [ - (#('----QUIT' '----SNAPSHOT') anySatisfy: [ :str | - chunk beginsWith: str ]) - ifTrue: [position := pos]]]. - block = 0 - ifTrue: [done := true] - ifFalse: [prevBlock := block. - block := block - 1024 max: 0]]. - changesFile close. - position - ifNil: [self inform: ('File {1} does not appear to be a changes file' translated format: {changesFile name})] - ifNotNil: [self browseRecentLogOn: origChangesFile startingFrom: position]! Item was removed: - ----- Method: ChangeList class>>browseRecentLogOn:startingFrom: (in category 'public access') ----- - browseRecentLogOn: origChangesFile startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i changesFile | - changesFile := origChangesFile readOnlyCopy. - banners := OrderedCollection new. - positions := OrderedCollection new. - end := changesFile size. - changesFile setConverterForCode. - pos := initialPos. - [pos = 0 - or: [banners size > 500]] - whileFalse: [changesFile position: pos. - chunk := changesFile nextChunk. - i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [positions addLast: pos. - banners - addLast: (chunk copyFrom: 5 to: i - 2). - pos := Number - readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [pos := 0]]. - changesFile close. - banners size = 0 ifTrue: [^ self inform: - 'this image has never been saved - since changes were compressed' translated]. - pos := UIManager default chooseFrom: banners values: positions title: 'Browse as far back as...' translated. - pos ifNil: [^ self]. - self browseRecent: end - pos on: origChangesFile! Item was removed: - ----- Method: ChangeList class>>browseRecentLogOnPath: (in category 'public access') ----- - browseRecentLogOnPath: fullName - "figure out where the last snapshot or quit was, then browse the recent entries." - - fullName - ifNotNil: - [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] - ifNil: - [Beeper beep] - ! Item was removed: - ----- Method: ChangeList class>>browseStream: (in category 'public access') ----- - browseStream: changesFile - "Opens a changeList on a fileStream" - | changeList charCount | - changesFile readOnly. - changesFile setConverterForCode. - charCount := changesFile size. - charCount > 1000000 ifTrue: - [(self confirm: ('The file {1} - is really long ({2} characters). - Would you prefer to view only the last million characters?' translated format: {changesFile name. charCount})) - ifTrue: [charCount := 1000000]]. - "changesFile setEncoderForSourceCodeNamed: changesFile name." - changeList := Cursor read showWhile: - [self new - scanFile: changesFile from: changesFile size-charCount to: changesFile size]. - changesFile close. - self open: changeList name: changesFile localName , ' log' multiSelect: true! Item was removed: - ----- Method: ChangeList class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') ----- - fileReaderServicesForFile: fullName suffix: suffix - | services | - services := OrderedCollection new. - (FileStream isSourceFileSuffix: suffix) | (suffix = '*') - ifTrue: [ services add: self serviceBrowseChangeFile ]. - (suffix = 'changes') | (suffix = '*') - ifTrue: [ services add: self serviceBrowseDotChangesFile ]. - (fullName asLowercase endsWith: '.cs.gz') | (suffix = '*') - ifTrue: [ services add: self serviceBrowseCompressedChangeFile ]. - ^services! Item was removed: - ----- Method: ChangeList class>>getRecentLocatorWithPrompt: (in category 'public access') ----- - getRecentLocatorWithPrompt: aPrompt - "Prompt with a menu of how far back to go. Return nil if user backs out. Otherwise return the number of characters back from the end of the .changes file the user wishes to include" - "ChangeList getRecentPosition" - | end changesFile banners positions pos chunk i | - changesFile := (SourceFiles at: 2) readOnlyCopy. - banners := OrderedCollection new. - positions := OrderedCollection new. - end := changesFile size. - pos := Smalltalk lastQuitLogPosition. - [pos = 0 or: [banners size > 20]] whileFalse: - [changesFile position: pos. - chunk := changesFile nextChunk. - i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 ifTrue: [positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i-2). - pos := Number readFrom: (chunk copyFrom: i+13 to: chunk size)] - ifFalse: [pos := 0]]. - changesFile close. - pos := UIManager default chooseFrom: banners values: positions title: aPrompt. - pos == nil ifTrue: [^ nil]. - ^ end - pos! Item was removed: - ----- Method: ChangeList class>>initialize (in category 'initialize-release') ----- - initialize - - FileServices registerFileReader: self! Item was removed: - ----- Method: ChangeList class>>open:name:multiSelect: (in category 'instance creation') ----- - open: aChangeList name: aString multiSelect: multiSelect - "Create a standard system view for the messageSet, whose label is aString. - The listView may be either single or multiple selection type" - ^ToolBuilder default open: aChangeList label: aString! Item was removed: - ----- Method: ChangeList class>>serviceBrowseChangeFile (in category 'fileIn/Out') ----- - serviceBrowseChangeFile - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'changelist browser' translatedNoop - selector: #browseStream: - description: 'open a changelist tool on this file' translatedNoop - buttonLabel: 'changes' translatedNoop) - argumentGetter: [ :fileList | fileList readOnlyStream ]! Item was removed: - ----- Method: ChangeList class>>serviceBrowseCompressedChangeFile (in category 'fileIn/Out') ----- - serviceBrowseCompressedChangeFile - "Answer a service for opening a changelist browser on a file" - - ^ SimpleServiceEntry - provider: self - label: 'changelist browser' translatedNoop - selector: #browseCompressedChangesFile: - description: 'open a changelist tool on this file' translatedNoop - buttonLabel: 'changes' translatedNoop! Item was removed: - ----- Method: ChangeList class>>serviceBrowseDotChangesFile (in category 'fileIn/Out') ----- - serviceBrowseDotChangesFile - "Answer a service for opening a changelist browser on the tail end of a .changes file" - - ^ SimpleServiceEntry - provider: self - label: 'recent changes in file' translatedNoop - selector: #browseRecentLogOnPath: - description: 'open a changelist tool on recent changes in file' translatedNoop - buttonLabel: 'recent changes' translatedNoop! Item was removed: - ----- Method: ChangeList class>>services (in category 'fileIn/Out') ----- - services - "Answer potential file services associated with this class" - - ^ { self serviceBrowseChangeFile. - self serviceBrowseDotChangesFile. - self serviceBrowseCompressedChangeFile }! Item was removed: - ----- Method: ChangeList class>>unload (in category 'class initialization') ----- - unload - - FileServices unregisterFileReader: self ! Item was removed: - ----- Method: ChangeList>>acceptFrom: (in category 'menu actions') ----- - acceptFrom: aView - - aView controller text = aView controller initialText ifFalse: [ - aView flash. - ^ self inform: 'You can only accept this version as-is. - If you want to edit, copy the text to a browser' translated]. - (aView setText: aView controller text from: self) ifTrue: - [aView ifNotNil: [aView controller accept]]. "initialText" - ! Item was removed: - ----- Method: ChangeList>>addItem:text: (in category 'initialization-release') ----- - addItem: item text: text - | cr | - cr := Character cr. - changeList addLast: item. - list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! Item was removed: - ----- Method: ChangeList>>annotation (in category 'viewing access') ----- - annotation - "Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact." - - | annot aChange aClass | - - annot := super annotation. - annot asString = '------' ifTrue: [^ annot]. - - ^ ((aChange := self currentChange) notNil and: [aChange methodSelector notNil]) - ifFalse: - [annot] - ifTrue: - [((aClass := aChange methodClass) isNil or: [(aClass includesSelector: aChange methodSelector) not]) - ifTrue: - [aChange methodClassName, ' >> ', aChange methodSelector, ' is not present in the current image.'] - ifFalse: - ['current version: ', annot]]! Item was removed: - ----- Method: ChangeList>>browseAllVersionsOfSelections (in category 'menu actions') ----- - browseAllVersionsOfSelections - "Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions." - | oldSelection aList | - oldSelection := self listIndex. - aList := OrderedCollection new. - Cursor read showWhile: [ - 1 to: changeList size do: [:i | - (listSelections at: i) ifTrue: [ - listIndex := i. - self browseVersions. - aList add: i. - ]]]. - listIndex := oldSelection. - - aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts' translated].! Item was removed: - ----- Method: ChangeList>>browseCurrentVersionsOfSelections (in category 'menu actions') ----- - browseCurrentVersionsOfSelections - "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" - | aList | - aList := OrderedCollection new. - Cursor read showWhile: [ - 1 to: changeList size do: [:i | - (listSelections at: i) ifTrue: [ - | aClass aChange | - aChange := changeList at: i. - (aChange type = #method - and: [(aClass := aChange methodClass) notNil - and: [aClass includesSelector: aChange methodSelector]]) - ifTrue: [ - aList add: ( - MethodReference class: aClass - selector: aChange methodSelector - ) - ]]]]. - - aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts' translated]. - ToolSet - browseMessageSet: aList - name: ('Current versions of selected methods in {1}' translated format: {file localName}) - autoSelect: nil! Item was removed: - ----- Method: ChangeList>>browseVersions (in category 'menu actions') ----- - browseVersions - | change class browser | - listIndex = 0 - ifTrue: [^ nil ]. - change := changeList at: listIndex. - ((class := change methodClass) notNil - and: [class includesSelector: change methodSelector]) - ifFalse: [ ^nil ]. - browser := super browseVersions. - browser ifNotNil: [ browser addedChangeRecord: change ]. - ^browser! Item was removed: - ----- Method: ChangeList>>buildChangeListWith:multiSelect: (in category 'toolbuilder') ----- - buildChangeListWith: builder multiSelect: multiSelect - - | listSpec | - multiSelect ifTrue:[ - listSpec := builder pluggableMultiSelectionListSpec new. - listSpec getSelectionList: #listSelectionAt:. - listSpec setSelectionList: #listSelectionAt:put:. - ] ifFalse:[ - listSpec := builder pluggableListSpec new. - ]. - - listSpec - model: self; - list: #list; - getIndex: #listIndex; - setIndex: #toggleListIndex:; - menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:]); - keyPress: #changeListKey:from:. - - ^listSpec! Item was removed: - ----- Method: ChangeList>>buildMorphicCodePaneWith: (in category 'menu actions') ----- - buildMorphicCodePaneWith: editString - - | codePane | - - codePane := AcceptableCleanTextMorph - on: self - text: #contents - accept: #contents: - readSelection: #contentsSelection - menu: #codePaneMenu:shifted:. - codePane font: Preferences standardCodeFont. - editString ifNotNil: [ - codePane editString: editString. - codePane hasUnacceptedEdits: true - ]. - ^codePane - ! Item was removed: - ----- Method: ChangeList>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - ^self buildWith: builder multiSelect: self showsVersions not! Item was removed: - ----- Method: ChangeList>>buildWith:multiSelect: (in category 'toolbuilder') ----- - buildWith: builder multiSelect: multiSelect - "Open a morphic view for the messageSet, whose label is labelString. - The listView may be either single or multiple selection type" - | windowSpec max | - max := self wantsOptionalButtons ifTrue:[0.33] ifFalse:[0.4]. - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 1 at max) -> [self buildChangeListWith: builder multiSelect: multiSelect]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - ^builder build: windowSpec! Item was removed: - ----- Method: ChangeList>>changeList (in category 'accessing') ----- - changeList - ^ changeList! Item was removed: - ----- Method: ChangeList>>changeListButtonSpecs (in category 'initialization-release') ----- - changeListButtonSpecs - - ^#( - ('select all' selectAll 'select all entries') - ('deselect all' deselectAll 'deselect all entries') - ('select conflicts' selectAllConflicts 'select all methods that occur in any change set') - ('file in selections' fileInSelections 'file in all selected entries') - )! Item was removed: - ----- Method: ChangeList>>changeListKey:from: (in category 'menu actions') ----- - changeListKey: aChar from: view - "Respond to a Command key in the list pane." - - aChar == $D ifTrue: [^ self toggleDiffing]. - aChar == $a ifTrue: [^ self selectAll]. - - ^ self arrowKey: aChar from: view! Item was removed: - ----- Method: ChangeList>>changeListMenu: (in category 'menu actions') ----- - changeListMenu: aMenu - ^ self menu: aMenu for: #(changeListMenu changeListMenuShifted) - ! Item was removed: - ----- Method: ChangeList>>changes:file: (in category 'accessing') ----- - changes: changeRecords file: aFile - file := aFile. - changeList := OrderedCollection new. - list := OrderedCollection new. - listIndex := 0. - changeRecords do: [:each | - (each respondsTo: #methodClass) - ifFalse: [self addItem: ChangeRecord new text: each asString] - ifTrue: - [self addItem: each text: ('method: ' , each methodClass name , (each isMetaClassChange ifTrue: [' class '] ifFalse: [' ']) - , each methodSelector - , '; ' , each stamp)]]. - listSelections := Array new: list size withAll: false! Item was removed: - ----- Method: ChangeList>>compareToCurrentSource: (in category 'menu actions') ----- - compareToCurrentSource: currentSource - "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" - - | change selectedSource | - change := changeList at: listIndex ifAbsent: [^ self]. - selectedSource := change string. - currentSource = selectedSource - ifTrue: [^ self inform: 'Exact Match' translated]. - (StringHolder new - textContents: (TextDiffBuilder - buildDisplayPatchFrom: selectedSource - to: currentSource - inClass: change methodClass - prettyDiffs: self showingPrettyDiffs)) - openLabel: 'Comparison to Current Version' translated.! Item was removed: - ----- Method: ChangeList>>compareToCurrentVersion (in category 'menu actions') ----- - compareToCurrentVersion - "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" - - | change class | - change := changeList at: listIndex ifAbsent: [^ self]. - class := change methodClass. - (class notNil and: [(class includesSelector: change methodSelector)]) - ifFalse: [^ self flash]. - ^ self compareToCurrentSource: (class sourceCodeAt: change methodSelector) asString! Item was removed: - ----- Method: ChangeList>>contents (in category 'viewing access') ----- - contents - "Answer the contents string, obeying diffing directives if needed" - - ^ self showingAnyKindOfDiffs - ifFalse: - [self undiffedContents] - ifTrue: - [self showsVersions - ifTrue: - [self diffedVersionContents] - ifFalse: - [self contentsDiffedFromCurrent]]! Item was removed: - ----- Method: ChangeList>>contents: (in category 'viewing access') ----- - contents: aString - listIndex = 0 ifTrue: [self changed: #flash. ^ false]. - lostMethodPointer ifNotNil: [^ self restoreDeletedMethod]. - self okToChange "means not dirty" ifFalse: ["is dirty" - self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' translated withCRs. ^ false]. - "Can't accept changes here. Method text must be unchanged!!" - (changeList at: listIndex) fileIn. - ^ true! Item was removed: - ----- Method: ChangeList>>contentsDiffedFromCurrent (in category 'viewing access') ----- - contentsDiffedFromCurrent - "Answer the contents diffed forward from current (in-memory) method version" - - | aChange aClass | - listIndex = 0 - ifTrue: [^ '']. - aChange := changeList at: listIndex. - (aChange type == #method - and: [(aClass := aChange methodClass) notNil - and: [aClass includesSelector: aChange methodSelector]]) ifTrue: - [^self - methodDiffFor: aChange text - class: aClass - selector: aChange methodSelector - prettyDiffs: self showingPrettyDiffs]. - - aChange type == #doIt ifTrue: - [| tokens | - tokens := Scanner new scanTokens: aChange string. - ((tokens select: - [:substr| #(subclass: variableByteSubclass: variableWordSubclass: - instanceVariableNames: classVariableNames: ) includes: substr]) - asSet size >= 3 - and: [(aClass := Smalltalk at: tokens third ifAbsent: []) notNil - and: [aClass isBehavior]]) ifTrue: - [^ClassDiffBuilder buildDisplayPatchFrom: aClass definition to: aChange string]. - - (tokens size = 4 - and: [tokens second == #class - and: [tokens third == #instanceVariableNames: - and: [(aClass := Smalltalk at: tokens first ifAbsent: []) notNil - and: [aClass isBehavior]]]]) ifTrue: - [^ClassDiffBuilder buildDisplayPatchFrom: aClass class definition to: aChange string]]. - - (aChange type == #classComment - and: [(aClass := aChange commentClass) notNil]) ifTrue: - [^ClassDiffBuilder buildDisplayPatchFrom: aClass comment asString to: aChange string]. - - ^(changeList at: listIndex) text! Item was removed: - ----- Method: ChangeList>>contentsSymbolQuints (in category 'viewing access') ----- - contentsSymbolQuints - "Answer a list of quintuplets representing information on the alternative views available in the code pane" - - ^ self sourceAndDiffsQuintsOnly! Item was removed: - ----- Method: ChangeList>>currentChange (in category 'accessing') ----- - currentChange - "return the current change being viewed, or nil if none" - listIndex = 0 ifTrue: [ ^nil ]. - ^changeList at: listIndex! Item was removed: - ----- Method: ChangeList>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.719 g: 0.9 b: 0.9)! Item was removed: - ----- Method: ChangeList>>deselectAll (in category 'menu actions') ----- - deselectAll - "Deselect all items in the list pane, and clear the code pane" - - listIndex := 0. - listSelections atAllPut: false. - self changed: #allSelections. - self contentsChanged! Item was removed: - ----- Method: ChangeList>>destroyCurrentCodeOfSelections (in category 'menu actions') ----- - destroyCurrentCodeOfSelections - "Actually remove from the system any in-memory methods with class and selector identical to items current selected. This may seem rather arcane but believe me it has its great uses, when trying to split out code. To use effectively, first file out a change set that you wish to split off. Then open a ChangeList browser on that fileout. Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command. For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!" - - | aClass aChange aList | - aList := OrderedCollection new. - 1 to: changeList size do: - [:index | - (listSelections at: index) ifTrue: - [aChange := changeList at: index. - (aChange type = #method - and: [(aClass := aChange methodClass) notNil - and: [aClass includesSelector: aChange methodSelector]]) - ifTrue: - [aList add: {aClass. aChange methodSelector}]]]. - - aList size > 0 ifTrue: - [(self confirm: ('Warning!! This will actually remove {1} method(s) from the system!!' translated format: {aList size})) ifFalse: [^ self]]. - aList do: - [:aPair | Transcript cr; show: 'Removed: ', aPair first printString, '.', aPair second. - aPair first removeSelector: aPair second]! Item was removed: - ----- Method: ChangeList>>diffedVersionContents (in category 'viewing access') ----- - diffedVersionContents - "Answer diffed version contents, maybe pretty maybe not" - - | change class earlier later | - (listIndex = 0 - or: [changeList size < listIndex]) - ifTrue: [^ '']. - change := changeList at: listIndex. - later := change text. - class := change methodClass: self environment. - (listIndex == changeList size or: [class == nil]) - ifTrue: [^ (self showingPrettyDiffs and: [class notNil]) - ifTrue: [class prettyPrinterClass format: later in: class notifying: nil] - ifFalse: [later]]. - - earlier := (changeList at: listIndex + 1) text. - - ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! Item was removed: - ----- Method: ChangeList>>file (in category 'accessing') ----- - file - ^file! Item was removed: - ----- Method: ChangeList>>fileInSelections (in category 'menu actions') ----- - fileInSelections - | any | - any := false. - self selectedClass environment beCurrentDuring: [ - listSelections with: changeList do: - [:selected :item | selected ifTrue: [any := true. item fileIn]]]. - any ifFalse: - [self inform: 'nothing selected, so nothing done' translated]! Item was removed: - ----- Method: ChangeList>>fileOutSelections (in category 'menu actions') ----- - fileOutSelections - | fileName internalStream | - fileName := Project uiManager request: 'Enter the base of file name' translated initialAnswer: 'Filename' translated. - internalStream := WriteStream on: (String new: 1000). - internalStream header; timeStamp. - listSelections with: changeList do: - [:selected :item | selected ifTrue: [item fileOutOn: internalStream]]. - - FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false.! Item was removed: - ----- Method: ChangeList>>initialize (in category 'initialization-release') ----- - initialize - "Initialize a blank ChangeList. Set the contentsSymbol to reflect whether diffs will initally be shown or not" - - contentsSymbol := Preferences diffsInChangeList - ifTrue: - [self defaultDiffsSymbol] - ifFalse: - [#source]. - changeList := OrderedCollection new. - list := OrderedCollection new. - listIndex := 0. - super initialize! Item was removed: - ----- Method: ChangeList>>invertSelections (in category 'menu actions') ----- - invertSelections - "Invert the selectedness of each item in the changelist" - - listSelections := listSelections collect: [ :ea | ea not]. - listIndex := 0. - self changed: #allSelections. - self contentsChanged! Item was removed: - ----- Method: ChangeList>>list (in category 'viewing access') ----- - list - ^ list! Item was removed: - ----- Method: ChangeList>>listHasSingleEntry (in category 'accessing') ----- - listHasSingleEntry - "does the list of changes have only a single item?" - ^list size = 1! Item was removed: - ----- Method: ChangeList>>listIndex (in category 'viewing access') ----- - listIndex - ^ listIndex! Item was removed: - ----- Method: ChangeList>>listSelectionAt: (in category 'viewing access') ----- - listSelectionAt: index - ^ listSelections at: index! Item was removed: - ----- Method: ChangeList>>listSelectionAt:put: (in category 'viewing access') ----- - listSelectionAt: index put: value - - listSelections at: index put: value. - self - changed: #listSelectionAt:; - changed: #listIndex. - ^ value! Item was removed: - ----- Method: ChangeList>>listSelections (in category 'accessing') ----- - listSelections - listSelections ifNil: [ - list ifNotNil: [ - listSelections := Array new: list size withAll: false]]. - ^ listSelections! Item was removed: - ----- Method: ChangeList>>mainChangeListMenu: (in category 'menu actions') ----- - mainChangeListMenu: aMenu - "Fill aMenu up so that it comprises the primary changelist-browser menu" - <changeListMenu> - - aMenu addTitle: 'change list' translated. - aMenu addStayUpItemSpecial. - - aMenu addTranslatedList: #( - - ('fileIn selections' fileInSelections 'import the selected items into the image') - ('fileOut selections...' fileOutSelections 'create a new file containing the selected items') - - - ('compare to current' compareToCurrentVersion 'open a separate window which shows the text differences between the on-file version and the in-image version.' ) - ('toggle diffing (D)' toggleDiffing 'start or stop showing diffs in the code pane.') - - - ('select conflicts with any changeset' selectAllConflicts 'select methods in the file which also occur in any change-set in the system') - ('select conflicts with current changeset' selectConflicts 'select methods in the file which also occur in the current change-set') - ('select conflicts with...' selectConflictsWith 'allows you to designate a file or change-set against which to check for code conflicts.') - - - ('select unchanged definitions' selectUnchangedDefinitions 'select class definitions, class comments and methods in the file whose in-image versions are the same as their in-file counterparts' ) - ('select unchanged methods' selectUnchangedMethods 'select methods in the file whose in-image versions are the same as their in-file counterparts' ) - ('select new methods' selectNewMethods 'select methods in the file that do not current occur in the image') - ('select methods for this class' selectMethodsForThisClass 'select all methods in the file that belong to the currently-selected class') - ('select methods for extant classes' selectMethodsForExtantClasses 'select all methods in the file that belong to a class that exists in the image') - ('select changes with contents matching' selectContentsMatching 'select all changes in the file whose text includes a pattern') - - - - ('select all (a)' selectAll 'select all the items in the list') - ('deselect all' deselectAll 'deselect all the items in the list') - ('invert selections' invertSelections 'select every item that is not currently selected, and deselect every item that *is* currently selected') - ('select all before' selectAllBefore 'select every item before the current selection') - - - ('browse all versions of single selection' browseVersions 'open a version browser showing the versions of the currently selected method') - ('browse all versions of selections' browseAllVersionsOfSelections 'open a version browser showing all the versions of all the selected methods') - ('browse current versions of selections' browseCurrentVersionsOfSelections 'open a message-list browser showing the current (in-image) counterparts of the selected methods') - ('destroy current methods of selections' destroyCurrentCodeOfSelections 'remove (*destroy*) the in-image counterparts of all selected methods') - - - ('remove doIts' removeDoIts 'remove all items that are doIts rather than methods') - ('remove older versions' removeOlderMethodVersions 'remove all but the most recent versions of methods in the list') - ('remove up-to-date versions' removeExistingMethodVersions 'remove all items whose code is the same as the counterpart in-image code') - ('remove selected items' removeSelections 'remove the selected items from the change-list') - ('remove unselected items' removeNonSelections 'remove all the items not currently selected from the change-list')). - - ^ aMenu! Item was removed: - ----- Method: ChangeList>>methodDiffFor:class:selector:prettyDiffs: (in category 'viewing access') ----- - methodDiffFor: aString class: aClass selector: aSelector prettyDiffs: prettyDiffBoolean - "Return a string comprising a source-code diff between an existing method and the source-code in aString. DO prettyDiff if prettyDiffBoolean is true." - - ^ (aClass notNil and: [aClass includesSelector: aSelector]) - ifTrue: - [TextDiffBuilder - buildDisplayPatchFrom: (aClass sourceCodeAt: aSelector) - to: aString - inClass: aClass - prettyDiffs: prettyDiffBoolean] - ifFalse: - [aString copy]! Item was removed: - ----- Method: ChangeList>>optionalButtonHeight (in category 'initialization-release') ----- - optionalButtonHeight - - ^ 15! Item was removed: - ----- Method: ChangeList>>perform:orSendTo: (in category 'menu actions') ----- - perform: selector orSendTo: otherTarget - "Selector was just chosen from a menu by a user. If I can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." - - (#accept == selector) ifTrue: - [otherTarget isMorph ifFalse: [^ self acceptFrom: otherTarget view]]. - "weird special case just for mvc changlist" - - ^ super perform: selector orSendTo: otherTarget! Item was removed: - ----- Method: ChangeList>>removeDoIts (in category 'menu actions') ----- - removeDoIts - "Remove doits from the receiver, other than initializes. 1/26/96 sw" - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - changeList with: list do: - [:chRec :str | - (chRec type ~~ #doIt or: - [str endsWith: 'initialize']) - ifTrue: - [newChangeList add: chRec. - newList add: str]]. - newChangeList size < changeList size - ifTrue: - [changeList := newChangeList. - list := newList. - listIndex := 0. - listSelections := Array new: list size withAll: false]. - self changed: #list. - - ! Item was removed: - ----- Method: ChangeList>>removeExistingMethodVersions (in category 'menu actions') ----- - removeExistingMethodVersions - "Remove all up to date version of entries from the receiver" - | newChangeList newList | - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - changeList with: list do:[:chRec :strNstamp | - | str keep cls sel | - keep := true. - (cls := chRec methodClass) ifNotNil:[ - str := chRec string. - sel := cls newParser parseSelector: str. - keep := (cls sourceCodeAt: sel ifAbsent:['']) asString ~= str. - ]. - keep ifTrue:[ - newChangeList add: chRec. - newList add: strNstamp]]. - newChangeList size < changeList size - ifTrue: - [changeList := newChangeList. - list := newList. - listIndex := 0. - listSelections := Array new: list size withAll: false]. - self changed: #list! Item was removed: - ----- Method: ChangeList>>removeNonSelections (in category 'menu actions') ----- - removeNonSelections - "Remove the unselected items from the receiver." - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - 1 to: changeList size do: - [:i | (listSelections at: i) ifTrue: - [newChangeList add: (changeList at: i). - newList add: (list at: i)]]. - newChangeList size = 0 ifTrue: - [^ self inform: 'That would remove everything. - Why would you want to do that?' translated]. - - newChangeList size < changeList size - ifTrue: - [changeList := newChangeList. - list := newList. - listIndex := 0. - listSelections := Array new: list size withAll: false]. - self changed: #list! Item was removed: - ----- Method: ChangeList>>removeOlderMethodVersions (in category 'menu actions') ----- - removeOlderMethodVersions - "Remove older versions of entries from the receiver." - | newChangeList newList found | - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - found := OrderedCollection new. - - changeList reverseWith: list do: - [:chRec :strNstamp | | str | str := strNstamp copyUpTo: $;. - (found includes: str) - ifFalse: - [found add: str. - newChangeList add: chRec. - newList add: strNstamp]]. - newChangeList size < changeList size - ifTrue: - [changeList := newChangeList reversed. - list := newList reversed. - listIndex := 0. - listSelections := Array new: list size withAll: false]. - self changed: #list! Item was removed: - ----- Method: ChangeList>>removeSelections (in category 'menu actions') ----- - removeSelections - "Remove the selected items from the receiver. 9/18/96 sw" - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - 1 to: changeList size do: - [:i | (listSelections at: i) ifFalse: - [newChangeList add: (changeList at: i). - newList add: (list at: i)]]. - newChangeList size < changeList size - ifTrue: - [changeList := newChangeList. - list := newList. - listIndex := 0. - listSelections := Array new: list size withAll: false]. - self changed: #list - - ! Item was removed: - ----- Method: ChangeList>>resetListSelections (in category 'initialization-release') ----- - resetListSelections - - listSelections := Array new: list size withAll: false.! Item was removed: - ----- Method: ChangeList>>restoreDeletedMethod (in category 'viewing access') ----- - restoreDeletedMethod - "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed. In this case we want to establish a sourceCode link to prior versions. We do this by installing a dummy method with the correct source code pointer prior to installing this version." - | dummyMethod class selector | - dummyMethod := CompiledMethod toReturnSelfTrailerBytes: - (CompiledMethodTrailer new sourcePointer: lostMethodPointer). - class := (changeList at: listIndex) methodClass. - selector := (changeList at: listIndex) methodSelector. - class addSelectorSilently: selector withMethod: dummyMethod. - (changeList at: listIndex) fileIn. - "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails." - (class compiledMethodAt: selector) == dummyMethod - ifTrue: [class basicRemoveSelector: selector]. - ^ true! Item was removed: - ----- Method: ChangeList>>scanCategory (in category 'scanning') ----- - scanCategory - "Scan anything that involves more than one chunk; method name is historical only" - - | itemPosition item tokens stamp anIndex class meta | - itemPosition := file position. - item := file nextChunk. - - ((item includesSubstring: 'commentStamp:') - or: [(item includesSubstring: 'methodsFor:') - or: [(item includesSubstring: 'classDefinition:') - or: [item endsWith: 'reorganize']]]) ifFalse: - ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" - ^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble) - text: ('preamble: ' , item contractTo: 50)]. - - tokens := Scanner new scanTokens: item. - tokens size >= 3 ifTrue: - [stamp := ''. - anIndex := tokens indexOf: #stamp: ifAbsent: [nil]. - anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)]. - - tokens second == #methodsFor: - ifTrue: [^ self scanCategory: tokens third class: tokens first - meta: false stamp: stamp]. - tokens third == #methodsFor: - ifTrue: [^ self scanCategory: tokens fourth class: tokens first - meta: true stamp: stamp]]. - - tokens second == #commentStamp: - ifTrue: - [stamp := tokens third. - self addItem: - (ChangeRecord new file: file position: file position type: #classComment - class: tokens first category: nil meta: false stamp: stamp) - text: 'class comment for ' , tokens first, - (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). - file nextChunk. - ^ file skipStyleChunk]. - - tokens first == #classDefinition: - ifTrue: - [class := tokens second. - meta := tokens size >= 3 and: [tokens third = 'class']. - stamp := ''. - self addItem: - (ChangeRecord new file: file position: file position type: #classDefinition - class: class category: nil meta: meta stamp: stamp) - text: 'class definition for ' , class, - (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). - file nextChunk. - ^ file skipStyleChunk]. - - self assert: tokens last == #reorganize. - self addItem: - (ChangeRecord new - file: file position: file position type: #reorganize - class: tokens first category: nil meta: false stamp: stamp) - text: 'organization for ' , tokens first, (tokens second == #class ifTrue: [' class'] ifFalse: ['']). - file nextChunk! Item was removed: - ----- Method: ChangeList>>scanCategory:class:meta:stamp: (in category 'scanning') ----- - scanCategory: category class: class meta: meta stamp: stamp - | itemPosition method selector | - [itemPosition := file position. - method := file nextChunk. - file skipStyleChunk. - method size > 0] "done when double terminators" - whileTrue: - [self addItem: (ChangeRecord new file: file position: itemPosition type: #method - class: class category: category meta: meta stamp: stamp) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , ((selector := ((Smalltalk classNamed: class) ifNil: [Object]) newParser parseSelector: method) isNil - ifTrue: ['unparsableSelector'] - ifFalse: [selector]) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! Item was removed: - ----- Method: ChangeList>>scanFile:from:to: (in category 'scanning') ----- - scanFile: aFile from: startPosition to: stopPosition - - file := aFile. - changeList := OrderedCollection new. - list := OrderedCollection new. - listIndex := 0. - file position: startPosition. - ('Scanning {1}...' translated format: {aFile localName}) - displayProgressFrom: startPosition to: stopPosition - during: [:bar | | prevChar itemPosition item | - [ [file position < stopPosition] - whileTrue: - [bar value: file position. - [file atEnd not and: [file peek isSeparator]] - whileTrue: [prevChar := file next]. - (file peekFor: $!!) - ifTrue: - [(prevChar = Character cr or: [prevChar = Character lf]) - ifTrue: [self scanCategory]] - ifFalse: - [itemPosition := file position. - item := file nextChunk. - file skipStyleChunk. - item size > 0 ifTrue: - [(item beginsWith: '----') - ifTrue: - [self addItem: (ChangeRecord new - file: file position: itemPosition type: #misc) - text: 'misc: ' , (item contractTo: 50)] - ifFalse: - [self addItem: (ChangeRecord new - file: file position: itemPosition type: #doIt) - text: 'do it: ' , (item contractTo: 50)]]]] - ] on: InvalidUTF8 do: [:ex | - aFile isSourceFile ifTrue: [ex pass] ifFalse: [ - self notify: ex messageText, '\\Proceed to try the legacy MacRoman encoding.' translated withCRs. - aFile reset; setConverterForOldCode. - ^ self scanFile: aFile from: startPosition to: stopPosition]] ]. - self resetListSelections.! Item was removed: - ----- Method: ChangeList>>selectAll (in category 'menu actions') ----- - selectAll - listIndex := 0. - listSelections atAllPut: true. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectAllBefore (in category 'menu actions') ----- - selectAllBefore - listIndex <= 1 ifTrue: - [Project current beep. - ^self changed: #flash]. - listSelections atAll: (1 to: listIndex - 1) put: true. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectAllConflicts (in category 'menu actions') ----- - selectAllConflicts - "Selects all method definitions in the receiver which are also in any existing change set in the system. This makes no statement about whether the content of the methods differ, only whether there is a change represented." - Cursor read showWhile: - [ | aClass aChange | - 1 to: changeList size do: - [:i | aChange := changeList at: i. - listSelections at: i put: - (aChange type = #method - and: [(aClass := aChange methodClass) notNil - and: [ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aChange methodSelector]])]]. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectConflicts (in category 'menu actions') ----- - selectConflicts - "Selects all method definitions for which there is ALSO an entry in changes" - Cursor read showWhile: - [ | change class | - 1 to: changeList size do: - [:i | change := changeList at: i. - listSelections at: i put: - (change type = #method - and: [(class := change methodClass) notNil - and: [(ChangeSet current atSelector: change methodSelector - class: class) ~~ #none]])]]. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectConflicts: (in category 'menu actions') ----- - selectConflicts: changeSetOrList - "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList" - Cursor read showWhile: - [ | change class | - (changeSetOrList isKindOf: ChangeSet) ifTrue: [ - 1 to: changeList size do: - [:i | change := changeList at: i. - listSelections at: i put: - (change type = #method - and: [(class := change methodClass) notNil - and: [(changeSetOrList atSelector: change methodSelector - class: class) ~~ #none]])]] - ifFalse: ["a ChangeList" - 1 to: changeList size do: - [:i | change := changeList at: i. - listSelections at: i put: - (change type = #method - and: [(class := change methodClass) notNil - and: [changeSetOrList list includes: (list at: i)]])]] - ]. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectConflictsWith (in category 'menu actions') ----- - 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 := ChangesOrganizer 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)]. - ! Item was removed: - ----- Method: ChangeList>>selectContentsMatching (in category 'menu actions') ----- - selectContentsMatching - | pattern | - pattern := Project uiManager request: 'pattern to match' translated. - pattern isEmpty ifTrue: [^self]. - ^Cursor execute showWhile: - [self selectSuchThat: ((pattern includesAnyOf: '?*') - ifTrue: [[ :change | pattern match: change string]] - ifFalse: [[ :change | change string includesSubstring: pattern]])]! Item was removed: - ----- Method: ChangeList>>selectMethodsForExtantClasses (in category 'menu actions') ----- - selectMethodsForExtantClasses - ^self selectSuchThat: - [ :change | - Smalltalk hasClassNamed: change methodClassName]! Item was removed: - ----- Method: ChangeList>>selectMethodsForThisClass (in category 'menu actions') ----- - selectMethodsForThisClass - self currentChange ifNil: [ ^self ]. - self currentChange methodClassName ifNotNil: - [:name| - self selectSuchThat: - (Sensor leftShiftDown - ifTrue: [[:change :index| (listSelections at: index) or: [change methodClassName = name]]] - ifFalse: [[:change| change methodClassName = name]])]! Item was removed: - ----- Method: ChangeList>>selectNewMethods (in category 'menu actions') ----- - selectNewMethods - "Selects all method definitions for which there is no counterpart method in the current image" - Cursor read showWhile: - [ | change class | - 1 to: changeList size do: - [:i | change := changeList at: i. - listSelections at: i put: - ((change type = #method and: - [((class := change methodClass) isNil) or: - [(class includesSelector: change methodSelector) not]]))]]. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectSuchThat (in category 'menu actions') ----- - selectSuchThat - "query the user for a selection criterio. By Lex Spoon. NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:" - | code block | - code := Project uiManager request: ('selection criteria for a change named aChangeRecord?\For instance, "{1}"' translated withCRs format: {'aChangeRecord category = ''System-Network'''}). - - code isEmpty ifTrue: [^ self ]. - - block := Compiler evaluate: '[:aChangeRecord | ', code, ']'. - - self selectSuchThat: block! Item was removed: - ----- Method: ChangeList>>selectSuchThat: (in category 'menu actions') ----- - selectSuchThat: aBlock - "select all changes for which block returns true" - listSelections := aBlock numArgs = 2 - ifTrue: [changeList withIndexCollect: aBlock] - ifFalse: [changeList collect: aBlock]. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectUnchangedDefinitions (in category 'menu actions') ----- - selectUnchangedDefinitions - "Selects all recognizable definitions for which there is already a definition in the current image, whose source is exactly the same." - | change class tokens | - Cursor read showWhile: - [1 to: changeList size do: - [:i | change := changeList at: i. - listSelections at: i put: false. - - (change type = #method - and: [(class := change methodClass) notNil - and: [class includesSelector: change methodSelector]]) ifTrue: - [listSelections - at: i - put: change string withBlanksCondensed - = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed]. - - (change type == #classComment - and: [(class := change commentClass) notNil]) ifTrue: - [listSelections at: i put: change string = class comment asString]. - - change type == #doIt ifTrue: - [tokens := Scanner new scanTokens: change string. - - ((tokens select: - [:substr| #(subclass: variableSubclass: variableByteSubclass: variableWordSubclass: - instanceVariableNames: classVariableNames: ) includes: substr]) - asSet size >= 3 - and: [(class := Smalltalk at: tokens third ifAbsent: []) notNil - and: [class isBehavior]]) ifTrue: - [listSelections - at: i - put: change string withBlanksCondensed - = class definition withBlanksCondensed]. - - (tokens size = 4 - and: [tokens second == #class - and: [tokens third == #instanceVariableNames: - and: [(class := Smalltalk at: tokens first ifAbsent: []) notNil - and: [class isBehavior]]]]) ifTrue: - [listSelections - at: i - put: change string withBlanksCondensed - = class class definition withBlanksCondensed]. - - (tokens size = 3 - and: [tokens second == #removeSelector: - and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil - or: [class isBehavior and: [(class includesSelector: tokens third) not]]]]) ifTrue: - [listSelections at: i put: true]. - - (tokens size = 4 - and: [tokens second == #class - and: [tokens third == #removeSelector: - and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil - or: [class isBehavior and: [(class class includesSelector: tokens fourth) not]]]]]) ifTrue: - [listSelections at: i put: true]]]]. - - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectUnchangedMethods (in category 'menu actions') ----- - selectUnchangedMethods - "Selects all method definitions for which there is already a method in the current image, whose source is exactly the same. 9/18/96 sw" - Cursor read showWhile: - [ | class change | - 1 to: changeList size do: - [:i | change := changeList at: i. - listSelections at: i put: - ((change type = #method and: - [(class := change methodClass) notNil]) and: - [(class includesSelector: change methodSelector) and: - [change string withBlanksCondensed = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed ]])]]. - self changed: #allSelections! Item was removed: - ----- Method: ChangeList>>selectedClass (in category 'viewing access') ----- - selectedClass - ^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! Item was removed: - ----- Method: ChangeList>>selectedClassOrMetaClass (in category 'viewing access') ----- - selectedClassOrMetaClass - | c | - ^ (c := self currentChange) ifNotNil: [c methodClass]! Item was removed: - ----- Method: ChangeList>>selectedMessageName (in category 'viewing access') ----- - selectedMessageName - | c | - ^ (c := self currentChange) ifNotNil: [c methodSelector]! Item was removed: - ----- Method: ChangeList>>setLostMethodPointer: (in category 'accessing') ----- - setLostMethodPointer: sourcePointer - lostMethodPointer := sourcePointer! Item was removed: - ----- Method: ChangeList>>showsVersions (in category 'accessing') ----- - showsVersions - ^ false! Item was removed: - ----- Method: ChangeList>>toggleListIndex: (in category 'viewing access') ----- - toggleListIndex: newListIndex - - listIndex = newListIndex ifTrue: [^ self]. - listIndex := newListIndex. - - self changed: #listIndex. - self contentsChanged! Item was removed: - ----- Method: ChangeList>>undiffedContents (in category 'viewing access') ----- - undiffedContents - ^ listIndex = 0 - ifTrue: [''] - ifFalse: [(changeList at: listIndex) text]! Item was removed: - ----- Method: ChangeList>>wantsPrettyDiffOption (in category 'initialization-release') ----- - wantsPrettyDiffOption - "Answer whether pretty-diffs are meaningful for this tool" - - ^ true! Item was removed: - ChangeList subclass: #ChangeListForProjects - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - - !ChangeListForProjects commentStamp: '<historical>' prior: 0! - A ChangeList that looks at the changes in a revokable project. This class has no users at present.! Item was removed: - ----- Method: ChangeListForProjects>>contents (in category 'contents') ----- - contents - ^ self showingAnyKindOfDiffs - ifFalse: [self undiffedContents] - ifTrue: [self currentDiffedFromContents] - "Current is writing over one in list. Show how I would change it"! Item was removed: - ----- Method: ChangeListForProjects>>currentDiffedFromContents (in category 'contents') ----- - currentDiffedFromContents - "Answer the current in-memory method diffed from the current contents" - - | aChange aClass | - listIndex = 0 - ifTrue: [^ '']. - aChange := changeList at: listIndex. - ^ ((aChange type == #method - and: [(aClass := aChange methodClass) notNil]) - and: [aClass includesSelector: aChange methodSelector]) - ifTrue: [TextDiffBuilder - buildDisplayPatchFrom: aChange text - to: (aClass sourceCodeAt: aChange methodSelector) - inClass: aClass - prettyDiffs: self showingPrettyDiffs] - ifFalse: [(changeList at: listIndex) text]! Item was removed: - ChangeSorter subclass: #ChangeSetBrowser - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - - !ChangeSetBrowser commentStamp: '<historical>' prior: 0! - A tool allowing you to browse the methods of a single change set.! Item was removed: - ----- Method: ChangeSetBrowser class>>on: (in category 'instance creation') ----- - on: aChangeSet - - ^ self new - myChangeSet: aChangeSet; - yourself! Item was removed: - ----- Method: ChangeSetBrowser class>>openOn: (in category 'instance creation') ----- - openOn: aChangeSet - - ^ ToolBuilder open: (self on: aChangeSet)! Item was removed: - ----- Method: ChangeSetBrowser class>>openOnCurrent (in category 'instance creation') ----- - openOnCurrent - - ^ self openOn: ChangeSet current! Item was removed: - ----- Method: ChangeSetBrowser>>addModelItemsToWindowMenu: (in category 'initialization') ----- - addModelItemsToWindowMenu: aMenu - "Add model-related items to the given window menu" - - | oldTarget | - oldTarget := aMenu defaultTarget. - aMenu defaultTarget: self. - aMenu addLine. - aMenu add: 'rename change set' translated action: #rename. - aMenu add: 'make changes go to me' translated action: #newCurrent. - aMenu addLine. - aMenu add: 'file out' translated action: #fileOut. - aMenu add: 'browse methods' translated action: #browseChangeSet. - aMenu addLine. - myChangeSet hasPreamble - ifTrue: - [aMenu add: 'edit preamble...' translated action: #editPreamble. - aMenu add: 'remove preamble' translated action: #removePreamble] - ifFalse: - [aMenu add: 'add preamble...' translated action: #editPreamble]. - - myChangeSet hasPostscript - ifTrue: - [aMenu add: 'edit postscript...' translated action: #editPostscript. - aMenu add: 'remove postscript' translated action: #removePostscript] - ifFalse: - [aMenu add: 'add postscript...' translated action: #editPostscript]. - aMenu addLine. - - aMenu add: 'destroy change set' translated action: #remove. - aMenu addLine. - Smalltalk isMorphic ifTrue: - [aMenu addLine. - aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu]. - aMenu addLine. - aMenu add: 'more...' translated action: #offerShiftedChangeSetMenu. - aMenu defaultTarget: oldTarget. - - ^ aMenu! Item was removed: - ----- Method: ChangeSetBrowser>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - - | max windowSpec | - max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5]. - windowSpec := self buildWindowWith: builder specs: { - (0.0 at 0.0 corner: 0.5 at max) -> [self buildClassListWith: builder]. - (0.5 at 0.0 corner: 1.0 at max) -> [self buildMessageListWith: builder]. - (0.0 at max corner: 1.0 at 1.0) -> [self buildCodePaneWith: builder] }. - ^ builder build: windowSpec! Item was removed: - ----- Method: ChangeSetBrowser>>changeSetMenuForDropInClassCats: (in category 'menu') ----- - changeSetMenuForDropInClassCats: aMenu - - ^ aMenu! Item was removed: - ----- Method: ChangeSetBrowser>>changeSetMenuForModification: (in category 'menu') ----- - changeSetMenuForModification: aMenu - - ^ aMenu! Item was removed: - ----- Method: ChangeSetBrowser>>changeSetMenuForOpposite: (in category 'menu') ----- - changeSetMenuForOpposite: aMenu - - ^ aMenu! Item was removed: - ----- Method: ChangeSetBrowser>>changeSetMenuForPromote: (in category 'menu') ----- - changeSetMenuForPromote: aMenu - - ^ aMenu! Item was removed: - ----- Method: ChangeSetBrowser>>offerUnshiftedChangeSetMenu (in category 'menu') ----- - offerUnshiftedChangeSetMenu - "The user chose 'more' from the shifted window menu; go back to the regular window menu" - - self containingWindow ifNotNil: [self containingWindow offerWindowMenu] ! Item was removed: - ----- Method: ChangeSetBrowser>>wantsAnnotationPane (in category 'initialization') ----- - wantsAnnotationPane - "This kind of browser always wants annotation panes, so answer true" - - ^ true! Item was removed: - ----- Method: ChangeSetBrowser>>wantsOptionalButtons (in category 'initialization') ----- - wantsOptionalButtons - "Sure, why not?" - - ^ true! Item was removed: - CodeHolder subclass: #ChangeSorter - instanceVariableNames: 'parent myChangeSet currentClassName currentSelector priorChangeSetList contentsAreStyleable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - - !ChangeSorter commentStamp: 'ct 3/10/2021 18:24' prior: 0! - I display a ChangeSet. Two of me are in a DualChangeSorter. - - aStringOrNil - Instance Variables - currentClassName: <aStringOrNil> - currentSelector: <aStringOrNil> - myChangeSet: <aChangeSet> - parent: <aDualChangeSorterOrNil> - priorChangeSetList: <aCollection> - contentsAreStyleable <aBoolean> - - - currentClassName - - string parseable into class-name [class] [class trait] - needs to be fitlered by (self withoutItemAnnotation: currentClassName) to remove pakaging note - - - currentSelector - - string parseable into selector-name - needs to be fitlered by (self withoutItemAnnotation: currentSelector) to remove pakaging note - - myChangeSet - - name of current changeset - parent - -the dual changesorter that contains this one. Used for dealing with the other half. - priorChangeSetList - - holds the current change set list. Used to detect changes in list when a newly generated list no long match the prior list.! Item was removed: - ----- Method: ChangeSorter class>>browseChangeSetsWithClass:selector: (in category 'browse') ----- - 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 := ChangeSet allChangeSets select: - [:cs | (cs atSelector: selector class: class) ~~ #none]. - hits isEmpty ifTrue: [^ self inform: ('{1}\is not in any change set' translated withCRs format: {class name, ' >> #', selector})]. - index := hits size = 1 - ifTrue: [1] - ifFalse: [(Project uiManager chooseFrom: (hits collect: [:cs | cs name]) - lines: #())]. - index = 0 ifTrue: [^ self]. - (ChangeSorter new myChangeSet: (hits at: index)) open. - ! Item was removed: - ----- Method: ChangeSorter class>>browseChangeSetsWithSelector: (in category 'browse') ----- - 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 := ChangeSet allChangeSets select: - [:cs | cs hasAnyChangeForSelector: aSelector]. - hits isEmpty ifTrue: [^ self inform: ('{1}\is not in any change set' translated withCRs format: {aSelector})]. - index := hits size = 1 - ifTrue: [1] - ifFalse: [(Project uiManager chooseFrom: (hits collect: [:cs | cs name]) - lines: #())]. - index = 0 ifTrue: [^ self]. - (ChangeSetBrowser new myChangeSet: (hits at: index)) open - - "ChangeSorter browseChangeSetsWithSelector: #clearPenTrails" - ! Item was removed: - ----- Method: ChangeSorter class>>initialize (in category 'class initialization') ----- - initialize - "ChangeSorter initialize" - - FileServices registerFileReader: self. - - self registerInFlapsRegistry. - ! Item was removed: - ----- Method: ChangeSorter class>>open (in category 'instance creation') ----- - open - "Open a new instance of the receiver's class" - - self new open! Item was removed: - ----- Method: ChangeSorter class>>prototypicalToolWindow (in category 'browse') ----- - prototypicalToolWindow - "Answer a window representing a prototypical instance of the receiver" - - ^ToolBuilder build: self new! Item was removed: - ----- Method: ChangeSorter class>>registerInFlapsRegistry (in category 'class initialization') ----- - registerInFlapsRegistry - "Register the receiver in the system's flaps registry" - self environment - at: #Flaps - ifPresent: [:cl | cl registerQuad: {#ChangeSorter. #prototypicalToolWindow. 'Change Set' translatedNoop. 'A tool that allows you to view and manipulate all the code changes in a single change set' translatedNoop} - forFlapNamed: 'Tools']! Item was removed: - ----- Method: ChangeSorter class>>unload (in category 'initialize-release') ----- - unload - "Unload the receiver from global registries" - - self environment at: #FileServices ifPresent: [:cl | - cl unregisterFileReader: self]. - self environment at: #Flaps ifPresent: [:cl | - cl unregisterQuadsWithReceiver: self] ! Item was removed: - ----- Method: ChangeSorter>>aboutToStyle: (in category 'code pane') ----- - aboutToStyle: aStyler - "This is a notification that aStyler is about to re-style its text. - Set the classOrMetaClass in aStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - aStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! Item was removed: - ----- Method: ChangeSorter>>addPriorVersionsCountForSelector:ofClass:to: (in category 'annotation') ----- - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset" - - (aClass includesSelector: aSelector) ifTrue: - [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. - aStream nextPutAll: - ((myChangeSet methodInfoFromRemoval: {aClass name. aSelector}) - ifNil: - ['no prior versions' translated] - ifNotNil: - ['version(s) retrievable here' translated]), self annotationSeparator! Item was removed: - ----- Method: ChangeSorter>>annotationForPackageforSelector:ofClass: (in category 'annotation') ----- - annotationForPackageforSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - "requestList" - | aCategory | - aClass ifNil: [ ^nil]. - aSelector ifNotNil: - [ aCategory := aClass organization categoryOfElement: aSelector. - (aCategory notNil and: [ aCategory first = $* ]) - ifTrue: [^ aCategory asString]] . - - "Ok. So the selector category does not indicate our package. We defer to the class category" - ^ aClass category asString. - ! Item was removed: - ----- Method: ChangeSorter>>basicClassList (in category 'class list') ----- - basicClassList - "Computed. View should try to preserve selections, even though index changes" - - ^ myChangeSet ifNotNil: [myChangeSet changedClassNames] ifNil: [OrderedCollection new] - ! Item was removed: - ----- Method: ChangeSorter>>basicMessageList (in category 'message list') ----- - basicMessageList - - | probe newSelectors className | - currentClassName ifNil: [^ #()]. - className := (self withoutItemAnnotation: currentClassName) . - probe := (className endsWith: ' class') - ifTrue: [className] - ifFalse: [className asSymbol]. - newSelectors := myChangeSet selectorsInClass: probe. - (newSelectors includes: (self selectedMessageName)) - ifFalse: [currentSelector := nil]. - ^ newSelectors sort - ! Item was removed: - ----- Method: ChangeSorter>>beginNote (in category 'annotation') ----- - beginNote - "return the string at the beginning of item annotation" - ^' {' - ! Item was removed: - ----- Method: ChangeSorter>>browseChangeSet (in category 'changeSet menu') ----- - browseChangeSet - "Open a message list browser on the new and changed methods in the current change set" - - ChangedMessageSet openFor: myChangeSet - - ! Item was removed: - ----- Method: ChangeSorter>>browseMethodConflicts (in category 'changeSet menu') ----- - browseMethodConflicts - "Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such." - - | aList | - - aList := myChangeSet - messageListForChangesWhich: [ :aClass :aSelector | - (ChangesOrganizer allChangeSetsWithClass: aClass selector: aSelector) size > 1 - ] - ifNone: [^ self inform: 'No other change set has changes - for any method in this change set.' translated]. - - ToolSet - browseMessageSet: aList - name: ('Methods in "{1}" that are also in other change sets ({2})' translated format: {myChangeSet name. aList size}) - autoSelect: nil! Item was removed: - ----- Method: ChangeSorter>>browseVersions (in category 'message list') ----- - browseVersions - "Create and schedule a changelist browser on the versions of the - selected message." - | class selector method category pair sourcePointer | - - (selector := self selectedMessageName) ifNil: [^ self]. - class := self selectedClassOrMetaClass. - (class includesSelector: selector) - ifTrue: [method := class compiledMethodAt: selector. - category := class whichCategoryIncludesSelector: selector. - sourcePointer := nil] - ifFalse: [pair := myChangeSet methodInfoFromRemoval: {class name. selector}. - pair ifNil: [^ nil]. - sourcePointer := pair first. - method := CompiledMethod toReturnSelfTrailerBytes: - (CompiledMethodTrailer new sourcePointer: sourcePointer). - category := pair second]. - VersionsBrowser - browseVersionsOf: method - class: self selectedClass meta: class isMeta - category: category selector: selector - lostMethodPointer: sourcePointer. - ! Item was removed: - ----- Method: ChangeSorter>>buildChangeSetListWith: (in category 'toolbuilder') ----- - buildChangeSetListWith: builder - - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #changeSetList; - getSelected: #currentCngSet; - setSelected: #showChangeSetNamed:; - menu: #changeSetMenu:shifted:; - keyPress: #changeSetListKey:from:; - dragItem: #dragChangeSet:; - autoDeselect: false. - ^ listSpec! Item was removed: - ----- Method: ChangeSorter>>buildClassListWith: (in category 'toolbuilder') ----- - buildClassListWith: builder - - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #classList; - getSelected: #currentClassName; - setSelected: #currentClassName:; - menu: #classListMenu:shifted:; - keyPress: #classListKey:from:; - dragItem: #dragClass:. - ^ listSpec! Item was removed: - ----- Method: ChangeSorter>>buildMessageListWith: (in category 'toolbuilder') ----- - buildMessageListWith: builder - - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #messageList; - getSelected: #currentSelector; - setSelected: #currentSelector:; - menu: #messageMenu:shifted:; - keyPress: #messageListKey:from:; - dragItem: #dragMessage:. - ^ listSpec! Item was removed: - ----- Method: ChangeSorter>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - - ^ self - buildWith: builder - in: (self buildWindowWith: builder) - rect: (0 at 0 extent: 1 at 1)! Item was removed: - ----- Method: ChangeSorter>>buildWith:in:rect: (in category 'toolbuilder') ----- - buildWith: builder in: window rect: rect - - | windowSpec offset factor | - offset := rect origin. - factor := rect extent. - windowSpec := self buildWindow: window with: builder specs: (({ - (0.0 at 0.0 corner: 0.5 at 0.25) -> [self buildChangeSetListWith: builder]. - (0.5 at 0.0 corner: 1.0 at 0.25) -> [self buildClassListWith: builder]. - (0.0 at 0.25 corner: 1.0 at 0.5) -> [self buildMessageListWith: builder]. - (0.0 at 0.5 corner: 1.0 at 1.0) -> [self buildCodePaneWith: builder] }) - collect: [:spec | ((spec key scaleBy: factor) translateBy: offset) -> spec value]). - ^ builder build: windowSpec! Item was removed: - ----- Method: ChangeSorter>>changeSet (in category 'access') ----- - changeSet - ^ myChangeSet! Item was removed: - ----- Method: ChangeSorter>>changeSetCategories (in category 'changeSet menu') ----- - changeSetCategories - - ^ ChangesOrganizer changeSetCategories! Item was removed: - ----- Method: ChangeSorter>>changeSetCurrentlyDisplayed (in category 'access') ----- - changeSetCurrentlyDisplayed - ^ myChangeSet! Item was removed: - ----- Method: ChangeSorter>>changeSetList (in category 'changeSet menu') ----- - changeSetList - "Answer a list of ChangeSet names to be shown in the change sorter." - - ^ChangeSet allChangeSets reverse collect: [:cs | cs name]! Item was removed: - ----- Method: ChangeSorter>>changeSetListKey:from: (in category 'changeSet menu') ----- - changeSetListKey: aChar from: view - "Respond to a Command key. I am a model with a listView that has a list of changeSets." - - aChar == $b ifTrue: [^ self browseChangeSet]. - aChar == $B ifTrue: [^ self openChangeSetBrowser]. - aChar == $c ifTrue: [^ self copyAllToOther]. - aChar == $D ifTrue: [^ self toggleDiffing]. - aChar == $f ifTrue: [^ self findCngSet]. - aChar == $m ifTrue: [^ self newCurrent]. - aChar == $n ifTrue: [^ self newSet]. - aChar == $o ifTrue: [^ self fileOut]. - aChar == $p ifTrue: [^ self editPreamble]. - aChar == $r ifTrue: [^ self rename]. - aChar == $x ifTrue: [^ self remove]. - aChar == $- ifTrue: [^ self subtractOtherSide]. - - ^ self messageListKey: aChar from: view! Item was removed: - ----- Method: ChangeSorter>>changeSetMenu:shifted: (in category 'changeSet menu') ----- - changeSetMenu: aMenu shifted: isShifted - - ^ self menu: aMenu for: #( changeSetMenu changeSetMenuShifted: ) shifted: isShifted - ! Item was removed: - ----- Method: ChangeSorter>>changeSetMenuForDropInClassCats: (in category 'changeSet menu') ----- - changeSetMenuForDropInClassCats: aMenu - - aMenu add: 'remove contained in class categories...' translated action: #removeContainedInClassCategories. - aMenu balloonTextForLastItem: ' Drops any changes in given class categories' translated. - - ^ aMenu - ! Item was removed: - ----- Method: ChangeSorter>>changeSetMenuForModification: (in category 'changeSet menu') ----- - changeSetMenuForModification: aMenu - - aMenu addLine. - - aMenu add: 'file into new...' translated action: #fileIntoNewChangeSet. - aMenu balloonTextForLastItem: - 'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)' translated. - - aMenu add: 'reorder all change sets' translated action: #reorderChangeSets. - aMenu balloonTextForLastItem: - 'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets' translated. - - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>changeSetMenuForOpposite: (in category 'changeSet menu') ----- - changeSetMenuForOpposite: aMenu - - parent ifNotNil: - [aMenu add: 'conflicts with change set opposite' translated action: #methodConflictsWithOtherSide. - aMenu balloonTextForLastItem: - 'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.' translated]. - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>changeSetMenuForPromote: (in category 'changeSet menu') ----- - changeSetMenuForPromote: aMenu - - aMenu add: 'promote to top of list' translated action: #promoteToTopChangeSet. - aMenu balloonTextForLastItem: - 'Make this change set appear first in change-set lists in all change sorters.' translated. - - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>checkForAlienAuthorship (in category 'changeSet menu') ----- - checkForAlienAuthorship - "Open a message list browser on all uncommented methods in the current change set that have alien authorship" - - myChangeSet checkForAlienAuthorship - - ! Item was removed: - ----- Method: ChangeSorter>>checkForAnyAlienAuthorship (in category 'changeSet menu') ----- - checkForAnyAlienAuthorship - "Open a message list browser on all uncommented methods in the current change set that have alien authorship, even historically" - - myChangeSet checkForAnyAlienAuthorship - - ! Item was removed: - ----- Method: ChangeSorter>>checkForUnclassifiedMethods (in category 'changeSet menu') ----- - checkForUnclassifiedMethods - "Open a message list browser on all methods in the current change set that have not been categorized" - - myChangeSet checkForUnclassifiedMethods - - ! Item was removed: - ----- Method: ChangeSorter>>checkForUncommentedClasses (in category 'changeSet menu') ----- - checkForUncommentedClasses - "Open a class list browser on classes in the change set that lack class comments" - - myChangeSet checkForUncommentedClasses! Item was removed: - ----- Method: ChangeSorter>>checkForUncommentedMethods (in category 'changeSet menu') ----- - checkForUncommentedMethods - "Open a message list browser on all uncommented methods in the current change set" - - myChangeSet checkForUncommentedMethods - - ! Item was removed: - ----- Method: ChangeSorter>>checkForUnsentMessages (in category 'changeSet menu') ----- - checkForUnsentMessages - "Open a message list browser on all unsent messages in the current change set" - - myChangeSet checkForUnsentMessages - - ! Item was removed: - ----- Method: ChangeSorter>>checkThatSidesDiffer: (in category 'changeSet menu') ----- - checkThatSidesDiffer: escapeBlock - "If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily" - - parent ifNil: [^ escapeBlock value]. "Not relevant unless in dual change sorter." - - (myChangeSet == (parent other: self) changeSet) - ifTrue: - [self inform: - 'This command requires that the - change sets selected on the two - sides of the change sorter *not* - be the same.' translated. - ^ escapeBlock value] - ! Item was removed: - ----- Method: ChangeSorter>>chooseCngSet (in category 'changeSet menu') ----- - chooseCngSet - "Present the user with an alphabetical list of change set names, and let her choose one" - - | changeSetsSortedAlphabetically chosen | - self okToChange ifFalse: [^ self]. - - changeSetsSortedAlphabetically := self changeSetList sorted: - [:a :b | a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits]. - - chosen := UIManager default chooseFrom: changeSetsSortedAlphabetically values: changeSetsSortedAlphabetically. - chosen ifNil: [^ self]. - self showChangeSet: (ChangesOrganizer changeSetNamed: chosen)! Item was removed: - ----- Method: ChangeSorter>>classList (in category 'class list') ----- - classList - "return the classlist with package note appended." - - ^ self basicClassList collect: [: each | - each asString, (self packageNoteForClass: (Smalltalk classNamed: each) selector: nil) ] .! Item was removed: - ----- Method: ChangeSorter>>classListKey:from: (in category 'class list') ----- - classListKey: aChar from: view - "Respond to a Command key in the class-list pane." - - aChar == $x ifTrue: [^ self removeClass]. - aChar == $d ifTrue: [^ self forgetClass]. - - ^ self messageListKey: aChar from: view "picks up b,h,p"! Item was removed: - ----- Method: ChangeSorter>>classListMenu:shifted: (in category 'class list') ----- - classListMenu: aMenu shifted: shifted - "Fill aMenu with items appropriate for the class list" - ^ self menu: aMenu for: #(classListMenu classListMenuShifted:) shifted: shifted - ! Item was removed: - ----- Method: ChangeSorter>>classMenu: (in category 'class list') ----- - classMenu: aMenu - "Set up aMenu for the class-list. Retained for backward compatibility with old change sorters in image segments" - - ^ self classListMenu: aMenu shifted: false! Item was removed: - ----- Method: ChangeSorter>>classMenu:shifted: (in category 'class list') ----- - classMenu: aMenu shifted: shifted - "Fill aMenu with items appropriate for the class list. Retained for bkwd compatibility" - - ^ self classListMenu: aMenu shifted: shifted! Item was removed: - ----- Method: ChangeSorter>>clearChangeSet (in category 'changeSet menu') ----- - clearChangeSet - "Clear out the current change set, after getting a confirmation." - | message | - - self okToChange ifFalse: [^ self]. - myChangeSet isEmpty ifFalse: - [message := 'Are you certain that you want to\forget all the changes in this set?' translated withCRs. - (self confirm: message) ifFalse: [^ self]]. - myChangeSet clear. - self changed: #classList. - self changed: #messageList. - self setContents. - self contentsChanged. - ! Item was removed: - ----- Method: ChangeSorter>>contents:notifying: (in category 'code pane') ----- - contents: aString notifying: aController - "Compile the code in aString. Notify aController of any syntax errors. - Create an error if the category of the selected message is unknown. - Answer false if the compilation fails. Otherwise, if the compilation - created a new method, deselect the current selection. Then answer true." - | category selector class oldSelector | - - (class := self selectedClassOrMetaClass) ifNil: - [(myChangeSet preambleString == nil or: [aString size = 0]) ifTrue: [ ^ false]. - (aString count: [:char | char == $"]) odd - ifTrue: [self inform: 'unmatched double quotes in preamble' translated] - ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [ - self inform: 'Part of the preamble is not within double-quotes. - To put a double-quote inside a comment, type two double-quotes in a row. - (Ignore this warning if you are including a doIt in the preamble.)' translated]]. - myChangeSet preambleString: aString. - self currentSelector: nil. "forces update with no 'unsubmitted chgs' feedback" - ^ true]. - oldSelector := self selectedMessageName. - category := class organization categoryOfElement: oldSelector. - selector := class compile: aString - classified: category - notifying: aController. - selector ifNil: [^ false]. - (self messageList includes: selector) - ifTrue: [self currentSelector: selector] - ifFalse: [self currentSelector: oldSelector]. - self update. - ^ true! Item was removed: - ----- Method: ChangeSorter>>copyAllToOther (in category 'changeSet menu') ----- - copyAllToOther - "Copy this entire change set into the one on the other side" - | companionSorter | - self checkThatSidesDiffer: [^ self]. - (companionSorter := parent other: self) changeSetCurrentlyDisplayed assimilateAllChangesFoundIn: myChangeSet. - companionSorter changed: #classList. "Later the changeSet itself will notice..." - companionSorter changed: #messageList! Item was removed: - ----- Method: ChangeSorter>>copyClassToOther (in category 'class list') ----- - copyClassToOther - "Place these changes in the other changeSet also" - - | otherSorter otherChangeSet | - self checkThatSidesDiffer: [^ self]. - self okToChange ifFalse: [^ Beeper beep]. - currentClassName ifNil: [^ Beeper beep]. - otherSorter := parent other: self. - otherChangeSet := otherSorter changeSet. - - otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. - otherSorter showChangeSet: otherChangeSet.! Item was removed: - ----- Method: ChangeSorter>>copyMethodToOther (in category 'message list') ----- - copyMethodToOther - "Place this change in the other changeSet also" - | other cls sel | - self checkThatSidesDiffer: [^ self]. - currentSelector ifNotNil: - [other := (parent other: self) changeSet. - cls := self selectedClassOrMetaClass. - sel := self selectedMessageName. - - other absorbMethod: sel class: cls from: myChangeSet. - (parent other: self) showChangeSet: other] - ! Item was removed: - ----- Method: ChangeSorter>>currentClassName (in category 'class list') ----- - currentClassName - - ^ currentClassName! Item was removed: - ----- Method: ChangeSorter>>currentClassName: (in category 'class list') ----- - currentClassName: aString - - currentClassName := aString. - self changed: #currentClassName. - self changed: #messageList. - - self currentSelector: (self messageList ifEmpty: [nil] ifNotEmpty: [:list | list first]). - ! Item was removed: - ----- Method: ChangeSorter>>currentCngSet (in category 'changeSet menu') ----- - currentCngSet - ^ myChangeSet name! Item was removed: - ----- Method: ChangeSorter>>currentSelector (in category 'message list') ----- - currentSelector - - ^ currentSelector! Item was removed: - ----- Method: ChangeSorter>>currentSelector: (in category 'message list') ----- - currentSelector: messageName - - currentSelector := messageName. - self changed: #currentSelector. - self setContents. - self contentsChanged. - self decorateButtons.! Item was removed: - ----- Method: ChangeSorter>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.719 g: 0.9 b: 0.9)! Item was removed: - ----- Method: ChangeSorter>>dragChangeSet: (in category 'dragging') ----- - dragChangeSet: anIndex - - anIndex = 0 ifTrue: [^ nil]. - ^ ChangesOrganizer changeSetNamed: (self changeSetList at: anIndex) ! Item was removed: - ----- Method: ChangeSorter>>dragClass: (in category 'dragging') ----- - dragClass: anIndex - - anIndex = 0 ifTrue: [^ nil]. - ^ (Smalltalk classNamed: (self basicClassList at: anIndex)) classReference! Item was removed: - ----- Method: ChangeSorter>>dragMessage: (in category 'dragging') ----- - dragMessage: anIndex - - anIndex = 0 ifTrue: [^ nil]. - ^ MethodReference - class: self selectedClassOrMetaClass - selector: (self basicMessageList at: anIndex)! Item was removed: - ----- Method: ChangeSorter>>editPostscript (in category 'changeSet menu') ----- - editPostscript - "Allow the user to edit the receiver's change-set's postscript -- in a separate window" - - myChangeSet editPostscript! Item was removed: - ----- Method: ChangeSorter>>editPreamble (in category 'changeSet menu') ----- - editPreamble - "Allow the user to edit the receiver's change-set's preamble -- in a separate window" - - myChangeSet editPreamble! Item was removed: - ----- Method: ChangeSorter>>endNote (in category 'annotation') ----- - endNote - "return the string at the beginning of item annotation" - ^'}' - ! Item was removed: - ----- Method: ChangeSorter>>expungeUniclasses (in category 'changeSet menu') ----- - expungeUniclasses - "remove all memory of uniclasses in the receiver" - - self okToChange ifFalse: [^ self]. - myChangeSet expungeUniclasses. - self changed: #classList. - self changed: #messageList. - - ! Item was removed: - ----- Method: ChangeSorter>>fileIntoNewChangeSet (in category 'changeSet menu') ----- - fileIntoNewChangeSet - "Obtain a file designation from the user, and file its contents into a - new change set whose name is a function of the filename. Show the - new set and leave the current changeSet unaltered." - self okToChange - ifFalse: [^ self]. - ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. - - (FileChooserDialog openOn: ChangeSet defaultChangeSetDirectory) ifNotNil: - [:fileName | - FileStream oldFileNamed: fileName do: - [:stream | | localName | - localName := FileDirectory localNameFor: fileName. - (ChangeSet newChangesFromStream: stream named: localName) - ifNotNil: [:aNewChangeSet | self showChangeSet: aNewChangeSet]]].! Item was removed: - ----- Method: ChangeSorter>>fileOut (in category 'changeSet menu') ----- - fileOut - "File out the current change set." - - myChangeSet fileOut. - parent modelWakeUp. "notice object conversion methods created" - ! Item was removed: - ----- Method: ChangeSorter>>fileOutClass (in category 'class list') ----- - fileOutClass - "this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000" - | aSet | - "File out the selected class set." - aSet := ChangeSet newChangeSet: (self withoutItemAnnotation: currentClassName). - aSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. - aSet fileOut. - ChangeSet removeChangeSet: aSet. - parent modelWakeUp. "notice object conversion methods created" - - ! Item was removed: - ----- Method: ChangeSorter>>findCngSet (in category 'changeSet menu') ----- - 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 := Project uiManager request: 'ChangeSet name or fragment?' translated. - pattern isEmpty ifTrue: [^ self]. - nameList := self changeSetList asSet. - candidates := ChangeSet 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 := Project uiManager chooseFrom: (candidates collect: [:each | each name]). - index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. - ! Item was removed: - ----- Method: ChangeSorter>>forget (in category 'message list') ----- - forget - "Drop this method from the changeSet" - - | className index messageList | - self okToChange ifFalse: [^ self]. - currentSelector ifNil: [^ self]. - className := self currentClassName. - index := self messageList indexOf: currentSelector. - myChangeSet - removeSelectorChanges: self selectedMessageName - class: self selectedClassOrMetaClass. - self changed: #classList. - self changed: #messageList. - (self classList includes: className) - ifFalse: ["Last entry removed" - self currentClassName: nil] - ifTrue: [ - messageList := self messageList. - self currentSelector: (messageList isEmpty ifFalse: - [messageList at: (index min: messageList size)])].! Item was removed: - ----- Method: ChangeSorter>>forgetClass (in category 'class list') ----- - forgetClass - "Remove all mention of this class from the changeSet. - After forgetting, select at the same point in the class - list, which helps if e.g. doing something repetitive such - as moving a number of classes to the other side." - | index classList | - self okToChange ifFalse: [^ self]. - currentClassName ifNil: [^self]. - index := self classList indexOf: currentClassName. - myChangeSet removeClassChanges: (self withoutItemAnnotation: currentClassName). - self changed: #classList. - classList := self classList. - self currentClassName: (classList isEmpty ifFalse: - [classList at: (index min: classList size)]).! Item was removed: - ----- Method: ChangeSorter>>goToChangeSetsProject (in category 'changeSet menu') ----- - goToChangeSetsProject - "Transport the user to a project which bears the selected changeSet as its current changeSet" - - | aProject | - (aProject := myChangeSet correspondingProject) - ifNotNil: - [aProject enter: false revert: false saveForRevert: false] - ifNil: - [self inform: 'Has no project' translated]! Item was removed: - ----- Method: ChangeSorter>>initialize (in category 'initialize') ----- - initialize - super initialize. - self showChangeSet: ChangeSet current.! Item was removed: - ----- Method: ChangeSorter>>inspectChangeSet (in category 'changeSet menu') ----- - inspectChangeSet - "Open a message list browser on the new and changed methods in the current change set" - - myChangeSet inspectWithLabel: ('Change set: {1}' translated format: {myChangeSet name}) - - ! Item was removed: - ----- Method: ChangeSorter>>isModeStyleable (in category 'contents') ----- - isModeStyleable - - ^ currentCompiledMethod notNil - and: [super isModeStyleable]! Item was removed: - ----- Method: ChangeSorter>>label (in category 'access') ----- - label - ^ self labelString! Item was removed: - ----- Method: ChangeSorter>>labelString (in category 'access') ----- - labelString - "The label for my entire window. The large button that displays my name is gotten via mainButtonName" - - ^ String streamContents: - [:aStream | - aStream nextPutAll: (ChangeSet current == myChangeSet - ifTrue: ['Changes go to "{1}"' translated format: {myChangeSet name}] - ifFalse: ['ChangeSet: {1}' translated format: {myChangeSet name}])]! Item was removed: - ----- Method: ChangeSorter>>lookForSlips (in category 'changeSet menu') ----- - lookForSlips - "Open a message list browser on the new and changed methods in the current change set" - - myChangeSet lookForSlips - - ! Item was removed: - ----- Method: ChangeSorter>>mailOut (in category 'changeSet menu') ----- - mailOut - "Create a mail with a gzipped attachment holding out the current change - set. " - myChangeSet mailOut. - parent modelWakeUp! Item was removed: - ----- Method: ChangeSorter>>mainButtonName (in category 'changeSet menu') ----- - mainButtonName - - ^ myChangeSet name! Item was removed: - ----- Method: ChangeSorter>>mainClassListMenu: (in category 'class list') ----- - mainClassListMenu: aMenu - "Fill aMenu with items appropriate for the class list" - - <classListMenuShifted: false> - aMenu title: 'class list' translated. - aMenu addStayUpItemSpecial. - parent ifNotNil: [ - aMenu addTranslatedList: #( "These two only apply to dual change sorters" - ('copy class chgs to other side' copyClassToOther) - ('move class chgs to other side' moveClassToOther))]. - - aMenu addTranslatedList: #( - - - ('delete class from change set (d)' forgetClass) - ('remove class from system (x)' removeClass) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' spawnHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('printOut' printOutClass) - ('fileOut' fileOutClass) - - - ('references... (r)' browseVariableReferences) - ('assignments... (a)' browseVariableAssignments) - ('class refs (N)' browseClassRefs) - - - ('more...' offerShiftedClassListMenu)). - - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>messageList (in category 'message list') ----- - messageList - | thisClass organization | - (thisClass := self selectedClassOrMetaClass) ifNil: [^ #() ] . - organization := thisClass organization. - ^self basicMessageList collect: [ :each | - each asString , (self noteString: (organization categoryOfElement: each))]. - ! Item was removed: - ----- Method: ChangeSorter>>messageListKey:from: (in category 'class list') ----- - messageListKey: aChar from: view - "Respond to a Command key in the message-list pane." - - aChar == $d ifTrue: [^ self forget]. - super messageListKey: aChar from: view! Item was removed: - ----- Method: ChangeSorter>>messageListMenu:shifted: (in category 'message list') ----- - messageListMenu: aMenu shifted: shifted - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - ^ self messageMenu: aMenu shifted: shifted! Item was removed: - ----- Method: ChangeSorter>>messageMenu:shifted: (in category 'message list') ----- - messageMenu: aMenu shifted: shifted - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - ^ self menu: aMenu for: #(messageListMenu messageListMenuShifted:) shifted: shifted! Item was removed: - ----- Method: ChangeSorter>>methodConflictsWithOtherSide (in category 'changeSet menu') ----- - methodConflictsWithOtherSide - "Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such." - - | aList other | - - self checkThatSidesDiffer: [^ self]. - other := (parent other: self) changeSet. - aList := myChangeSet - messageListForChangesWhich: [ :aClass :aSelector | - aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector] - ] - ifNone: [^ self inform: 'There are no methods that appear - both in this change set and - in the one on the other side.' translated]. - - ToolSet - browseMessageSet: aList - name: ('Methods in "{1}" that are also in {2} ({3})' translated format: {myChangeSet name. other name. aList size}) - autoSelect: nil! Item was removed: - ----- Method: ChangeSorter>>modelWakeUp (in category 'access') ----- - modelWakeUp - "A window with me as model is being entered. - Make sure I am up-to-date with the changeSets." - - self canDiscardEdits ifTrue: [self update]! Item was removed: - ----- Method: ChangeSorter>>moveClassToOther (in category 'class list') ----- - moveClassToOther - "Place class changes in the other changeSet and remove them from this one" - - self checkThatSidesDiffer: [^ self]. - (self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep]. - - self copyClassToOther. - self forgetClass! Item was removed: - ----- Method: ChangeSorter>>moveMethodToOther (in category 'message list') ----- - moveMethodToOther - "Place this change in the other changeSet and remove it from this side" - - | other cls sel | - self checkThatSidesDiffer: [^self]. - self okToChange ifFalse: [^Beeper beep]. - currentSelector ifNotNil: - [other := (parent other: self) changeSet. - other == myChangeSet ifTrue: [^Beeper beep]. - cls := self selectedClassOrMetaClass. - sel := self selectedMessageName. - other - absorbMethod: sel - class: cls - from: myChangeSet. - (parent other: self) showChangeSet: other. - self forget "removes the method from this side"]! Item was removed: - ----- Method: ChangeSorter>>myChangeSet: (in category 'access') ----- - myChangeSet: anObject - myChangeSet := anObject! Item was removed: - ----- Method: ChangeSorter>>newCurrent (in category 'changeSet menu') ----- - newCurrent - "make my change set be the current one that changes go into" - - ChangeSet newChanges: myChangeSet. - self update. "Because list of changes in a category may thus have changed" - self changed: #relabel.! Item was removed: - ----- Method: ChangeSorter>>newSet (in category 'changeSet menu') ----- - newSet - "Create a new changeSet and show it., making it the current one. Reject name if already in use." - - | aSet | - self okToChange ifFalse: [^ self]. - aSet := ChangeSet newChangeSet. - aSet ifNotNil:[ - self update. - self showChangeSet: aSet. - self changed: #relabel]! Item was removed: - ----- Method: ChangeSorter>>noteString: (in category 'annotation') ----- - noteString: aString - ^ self beginNote , aString asString , self endNote! Item was removed: - ----- Method: ChangeSorter>>offerShiftedChangeSetMenu (in category 'changeSet menu') ----- - offerShiftedChangeSetMenu - "Offer the shifted version of the change set menu" - - self offerMenuFrom: #changeSetMenu:shifted: shifted: true! Item was removed: - ----- Method: ChangeSorter>>offerUnshiftedChangeSetMenu (in category 'changeSet menu') ----- - offerUnshiftedChangeSetMenu - "Offer the unshifted version of the change set menu" - - self offerMenuFrom: #changeSetMenu:shifted: shifted: false! Item was removed: - ----- Method: ChangeSorter>>open (in category 'creation') ----- - open - "ChangeSorterPluggable new open" - ^ToolBuilder open: self! Item was removed: - ----- Method: ChangeSorter>>openChangeSetBrowser (in category 'changeSet menu') ----- - openChangeSetBrowser - "Open a ChangeSet browser on the current change set" - ToolBuilder open: (ChangeSetBrowser new myChangeSet: myChangeSet)! Item was removed: - ----- Method: ChangeSorter>>packageNoteForClass:selector: (in category 'annotation') ----- - packageNoteForClass: aClass selector: aSelector - "return the category name that represents the package name for aClass>>aSelector. - when selector is nil or in a normal catagory return " - | package | - package := (self annotationForPackageforSelector: aSelector - ofClass: aClass) ifNil: ['<class was deleted???>' translated] . - - ^ self noteString: package - - - - - - - ! Item was removed: - ----- Method: ChangeSorter>>parent (in category 'access') ----- - parent - ^ parent! Item was removed: - ----- Method: ChangeSorter>>parent: (in category 'access') ----- - parent: anObject - parent := anObject! Item was removed: - ----- Method: ChangeSorter>>promoteToTopChangeSet (in category 'changeSet menu') ----- - promoteToTopChangeSet - "Move the selected change-set to the top of the list" - - ChangeSet promoteToTop: myChangeSet. - (parent ifNil: [self]) modelWakeUp! Item was removed: - ----- Method: ChangeSorter>>remove (in category 'changeSet menu') ----- - remove - "Completely destroy my change set. Check if it's OK first" - - self okToChange ifFalse: [^ self]. - self removePrompting: true. - self update! Item was removed: - ----- Method: ChangeSorter>>removeContainedInClassCategories (in category 'changeSet menu') ----- - removeContainedInClassCategories - | matchExpression | - myChangeSet removePreamble. - matchExpression := Project uiManager request: 'Enter class category name (wildcard is ok)' translated initialAnswer: 'System-*'. - (Smalltalk organization categories - select: [:each | matchExpression match: each]) - do: [:eachCat | - | classNames | - classNames := Smalltalk organization listAtCategoryNamed: eachCat. - classNames - do: [:eachClassName | - myChangeSet removeClassChanges: eachClassName. - myChangeSet removeClassChanges: eachClassName , ' class']. - self showChangeSet: myChangeSet]! Item was removed: - ----- Method: ChangeSorter>>removeFromCurrentChanges (in category 'message list') ----- - removeFromCurrentChanges - "Redisplay after removal in case we are viewing the current changeSet" - - super removeFromCurrentChanges. - currentSelector := nil. - self showChangeSet: myChangeSet! Item was removed: - ----- Method: ChangeSorter>>removeMessage (in category 'message list') ----- - removeMessage - - ^ super removeMessage - ifTrue: [self update]; - yourself! Item was removed: - ----- Method: ChangeSorter>>removePostscript (in category 'changeSet menu') ----- - removePostscript - (myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue: - [^ self inform: - 'Cannot remove the postscript right - now because there is at least one - window open on that postscript. - Close that window and try again.' translated]. - - myChangeSet removePostscript.! Item was removed: - ----- Method: ChangeSorter>>removePreamble (in category 'changeSet menu') ----- - removePreamble - myChangeSet removePreamble.! Item was removed: - ----- Method: ChangeSorter>>removePrompting: (in category 'changeSet menu') ----- - removePrompting: doPrompt - "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first." - - | message aName changeSetNumber msg | - aName := myChangeSet name. - myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" - (myChangeSet isEmpty or: [doPrompt not]) ifFalse: - [message := 'Are you certain that you want to - remove (destroy) the change set - named "{1}" ?' translated format: {aName}. - (self confirm: message) ifFalse: [^ self]]. - - doPrompt ifTrue: - [msg := myChangeSet hasPreamble - ifTrue: - [myChangeSet hasPostscript - ifTrue: - ['a preamble and a postscript' translated] - ifFalse: - ['a preamble' translated]] - ifFalse: - [myChangeSet hasPostscript - ifTrue: - ['a postscript' translated] - ifFalse: - ['']]. - msg isEmpty ifFalse: - [(self confirm: - ('Caution!! This change set has - {1} which will be - lost if you destroy the change set. - Do you really want to go ahead with this?' translated format: {msg})) ifFalse: [^ self]]]. - - "Go ahead and remove the change set" - changeSetNumber := myChangeSet name initialIntegerOrNil. - changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber]. - ChangesOrganizer removeChangeSet: myChangeSet. - self changed: #changeSetList. - self showChangeSet: ChangeSet current.! Item was removed: - ----- Method: ChangeSorter>>rename (in category 'changeSet menu') ----- - rename - "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" - - | newName | - newName := Project uiManager request: 'New name for this change set' translated - initialAnswer: myChangeSet name. - (newName = myChangeSet name or: [newName size = 0]) ifTrue: - [^ self]. - - (ChangeSet named: newName) ifNotNil: - [^ Project uiManager inform: 'Sorry that name is already used' translated]. - - myChangeSet name: newName. - self update. - self changed: #mainButtonName. - self changed: #relabel.! Item was removed: - ----- Method: ChangeSorter>>reorderChangeSets (in category 'changeSet menu') ----- - reorderChangeSets - "apply a standard reordering -- let the class handle this" - - ^ ChangesOrganizer reorderChangeSets! Item was removed: - ----- Method: ChangeSorter>>selectedClass (in category 'class list') ----- - selectedClass - "Answer the currently-selected class. If there is no selection, or if the selection refers to a class no longer extant, return nil" - | c | - ^ currentClassName ifNotNil: [(c := self selectedClassOrMetaClass) - ifNotNil: [c theNonMetaClass]]! Item was removed: - ----- Method: ChangeSorter>>selectedClassOrMetaClass (in category 'traits') ----- - selectedClassOrMetaClass - "Careful, the class may have been removed!!" - - | cName tName className | - currentClassName ifNil: [^ nil]. - className := (self withoutItemAnnotation: currentClassName) . - (className endsWith: ' class') - ifTrue: [cName := (className copyFrom: 1 to: className size-6) asSymbol. - ^ (Smalltalk at: cName ifAbsent: [^nil]) class]. - (currentClassName endsWith: ' classTrait') - ifTrue: [tName := (className copyFrom: 1 to: className size-11) asSymbol. - ^ (Smalltalk at: tName ifAbsent: [^nil]) classTrait]. - cName := className asSymbol. - ^ Smalltalk at: cName ifAbsent: [nil]! Item was removed: - ----- Method: ChangeSorter>>selectedMessageName (in category 'message list') ----- - selectedMessageName - - currentSelector ifNil: [^ nil]. - ^ (self withoutItemAnnotation: currentSelector) asSymbol! Item was removed: - ----- Method: ChangeSorter>>setContents (in category 'code pane') ----- - setContents - "return the source code that shows in the bottom pane" - - | sel class strm changeType | - self clearUserEditFlag. - contentsAreStyleable := false. - currentCompiledMethod := nil. - myChangeSet ifNil: [^ contents := String empty]. "should not happen but can" - currentClassName ifNil: [^ contents := myChangeSet preambleString ifNil: [String empty]]. - class := self selectedClassOrMetaClass. - (sel := self selectedMessageName) == nil - ifFalse: [changeType := (myChangeSet atSelector: (sel := sel asSymbol) class: class). - changeType == #remove - ifTrue: [^ contents := 'Method has been removed (see versions)' translated]. - changeType == #addedThenRemoved - ifTrue: [^ contents := 'Added then removed (see versions)' translated]. - class ifNil: [^ contents := 'Method was added, but cannot be found!!' translated]. - (class includesSelector: sel) - ifFalse: [^ contents := 'Method was added, but cannot be found!!' translated]. - contentsAreStyleable := true. - currentCompiledMethod := class compiledMethodAt: sel. - contents := class sourceCodeAt: sel. - (#(prettyPrint prettyDiffs) includes: contentsSymbol) ifTrue: - [contents := class prettyPrinterClass - format: contents in: class notifying: nil]. - self showingAnyKindOfDiffs ifTrue: [ - contentsAreStyleable := false. - contents := self diffFromPriorSourceFor: contents]. - ^ contents := contents asText makeSelectorBoldIn: class] - ifTrue: [strm := WriteStream on: (String new: 100). - (myChangeSet classChangeAt: (self withoutItemAnnotation: currentClassName)) do: - [:each | - each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.' translated; cr]. - each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.' translated]. - each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.' translated; cr]. - each = #add ifTrue: [strm nextPutAll: 'Class definition was added.' translated; cr]. - each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.' translated; cr]. - each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.' translated; cr]. - each = #comment ifTrue: [strm nextPutAll: 'New class comment.' translated; cr. - ]]. - ^ contents := strm contents].! Item was removed: - ----- Method: ChangeSorter>>setRecentUpdatesMarker (in category 'changeSet menu') ----- - setRecentUpdatesMarker - "Allow the user to change the recent-updates marker" - - | result | - result := Project uiManager request: - ('Enter the lowest change-set number - that you wish to consider "recent"? - (note: highest change-set number - in this image at this time is {1})' translated format: {ChangeSet highestNumberedChangeSet}) initialAnswer: ChangesOrganizer recentUpdateMarker recentUpdateMarker asString. - (result notNil and: [result startsWithDigit]) ifTrue: - [ChangesOrganizer recentUpdateMarker: result asInteger. - Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]]! Item was removed: - ----- Method: ChangeSorter>>shiftedChangeSetMenu: (in category 'changeSet menu') ----- - shiftedChangeSetMenu: aMenu - "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" - - <changeSetMenuShifted: true> - - aMenu title: 'Change set (shifted)' translated. - aMenu addStayUpItemSpecial. - - "CONFLICTS SECTION" - aMenu add: 'conflicts with other change sets' translated action: #browseMethodConflicts. - aMenu balloonTextForLastItem: - 'Browse all methods that occur both in this change set and in at least one other change set.' translated. - self changeSetMenuForOpposite: aMenu. - aMenu addLine. - - "CHECKS SECTION" - aMenu add: 'check for slips' translated action: #lookForSlips. - aMenu balloonTextForLastItem: - 'Check this change set for halts and references to Transcript.' translated. - - aMenu add: 'check for unsent messages' translated action: #checkForUnsentMessages. - aMenu balloonTextForLastItem: - 'Check this change set for messages that are not sent anywhere in the system' translated. - - aMenu add: 'check for uncommented methods' translated action: #checkForUncommentedMethods. - aMenu balloonTextForLastItem: - 'Check this change set for methods that do not have comments' translated. - - aMenu add: 'check for uncommented classes' translated action: #checkForUncommentedClasses. - aMenu balloonTextForLastItem: - 'Check for classes with code in this changeset which lack class comments' translated. - - Utilities authorInitialsPerSe isEmptyOrNil ifFalse: - [aMenu add: 'check for other authors' translated action: #checkForAlienAuthorship. - aMenu balloonTextForLastItem: - ('Check this change set for methods whose current authoring stamp does not start with "{1}"' translated format: {Utilities authorInitials}). - - aMenu add: 'check for any other authors' translated action: #checkForAnyAlienAuthorship. - aMenu balloonTextForLastItem: - ('Check this change set for methods any of whose authoring stamps do not start with "{1}"' translated format: {Utilities authorInitials})]. - - aMenu add: 'check for uncategorized methods' translated action: #checkForUnclassifiedMethods. - aMenu balloonTextForLastItem: - 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.' translated. - aMenu addLine. - - aMenu add: 'inspect change set' translated action: #inspectChangeSet. - aMenu balloonTextForLastItem: - 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)' translated. - - aMenu add: 'update' translated action: #update. - aMenu balloonTextForLastItem: - 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)' translated. - - aMenu add: 'go to change set''s project' translated action: #goToChangeSetsProject. - aMenu balloonTextForLastItem: - 'If this change set is currently associated with a Project, go to that project right now.' translated. - - self changeSetMenuForPromote: aMenu. - - aMenu add: 'trim history' translated action: #trimHistory. - aMenu balloonTextForLastItem: - ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes' translated. - - self changeSetMenuForDropInClassCats: aMenu. - - aMenu add: 'clear this change set' translated action: #clearChangeSet. - aMenu balloonTextForLastItem: - 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!' translated. - aMenu add: 'expunge uniclasses' translated action: #expungeUniclasses. - aMenu balloonTextForLastItem: - 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.' translated. - - aMenu add: 'uninstall this change set' translated action: #uninstallChangeSet. - aMenu balloonTextForLastItem: - 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!' translated. - - self changeSetMenuForModification: aMenu. - - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>shiftedChangeSetMore: (in category 'changeSet menu') ----- - shiftedChangeSetMore: aMenu - <changeSetMenuShifted: false> - <menuPriority: 1000> - ^ aMenu addTranslatedList: #( - - - ('more...' offerShiftedChangeSetMenu)); - yourself! Item was removed: - ----- Method: ChangeSorter>>shiftedClassListMenu: (in category 'class list') ----- - shiftedClassListMenu: aMenu - "Fill aMenu with items appropriate for the class list" - <classListMenuShifted: true> - - aMenu title: 'class list' translated. - aMenu addStayUpItemSpecial. - - aMenu addTranslatedList: #( - - - ('unsent methods' browseUnusedMethods) - ('unreferenced inst vars' showUnreferencedInstVars) - ('unreferenced class vars' showUnreferencedClassVars) - - - ('sample instance' makeSampleInstance) - ('inspect instances' inspectInstances) - ('inspect subinstances' inspectSubInstances) - - - ('more...' offerUnshiftedClassListMenu )). - - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>shiftedMessageMenu: (in category 'message list') ----- - shiftedMessageMenu: aMenu - "Arm the menu so that it holds items appropriate to the message-list while the shift key is down. Answer the menu." - <messageListMenuShifted: true> - ^ aMenu addTranslatedList: #( - - - ('toggle diffing (D)' toggleDiffing) - ('implementors of sent messages' browseAllMessages) - ('change category...' changeCategory) - - - ('sample instance' makeSampleInstance) - ('inspect instances' inspectInstances) - ('inspect subinstances' inspectSubInstances) - - - ('change sets with this method' findMethodInChangeSets) - ('revert to previous version' revertToPreviousVersion) - ('revert & remove from changes' revertAndForget)); - yourself - ! Item was removed: - ----- Method: ChangeSorter>>showChangeSet: (in category 'access') ----- - showChangeSet: chgSet - - myChangeSet == chgSet ifFalse: [ - myChangeSet := chgSet. - currentClassName := nil. - currentSelector := nil]. - self changed: #relabel. - self changed: #currentCngSet. "new -- list of sets" - self changed: #mainButtonName. "old, button" - self changed: #classList. - - self currentClassName: (self classList ifEmpty: [nil] ifNotEmpty: [:list | list first]).! Item was removed: - ----- Method: ChangeSorter>>showChangeSetNamed: (in category 'access') ----- - showChangeSetNamed: aName - - self showChangeSet: (ChangesOrganizer changeSetNamed: aName) ! Item was removed: - ----- Method: ChangeSorter>>submergeIntoOtherSide (in category 'changeSet menu') ----- - submergeIntoOtherSide - "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." - | other message nextToView i all | - self checkThatSidesDiffer: [^ self]. - self okToChange ifFalse: [^ self]. - other := (parent other: self) changeSet. - other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!' translated]. - myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove, - simply choose "remove".' translated]. - - myChangeSet okayToRemove ifFalse: [^ self]. - message := 'Please confirm: copy all changes - in "{1}" into "{2}" - and then destroy the change set - named "{3}"?' translated format: {myChangeSet name. other name. myChangeSet name}. - - (self confirm: message) ifFalse: [^ self]. - - (myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue: - [(self confirm: - 'Caution!! This change set has a preamble or - a postscript or both. If you submerge it into - the other side, these will be lost. - Do you really want to go ahead with this?' translated) ifFalse: [^ self]]. - - other assimilateAllChangesFoundIn: myChangeSet. - all := ChangeSet allChangeSets. - nextToView := ((all includes: myChangeSet) - and: [(i := all indexOf: myChangeSet) < all size]) - ifTrue: [all at: i+1] - ifFalse: [other]. - - self removePrompting: false. - self showChangeSet: nextToView. - parent modelWakeUp.! Item was removed: - ----- Method: ChangeSorter>>subtractOtherSide (in category 'changeSet menu') ----- - subtractOtherSide - "Subtract the changes found on the other side from the requesting side." - self checkThatSidesDiffer: [^ self]. - myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet). - self showChangeSet: myChangeSet! Item was removed: - ----- Method: ChangeSorter>>toggleDiffing (in category 'code pane') ----- - toggleDiffing - "Toggle whether diffs should be shown in the code pane" - - self okToChange ifTrue: - [super toggleDiffing. - self changed: #contents. - self update] - - ! Item was removed: - ----- Method: ChangeSorter>>trimHistory (in category 'changeSet menu') ----- - trimHistory - "Drop non-essential history (rename, reorg, method removals) from newly-added classes." - - myChangeSet trimHistory - - ! Item was removed: - ----- Method: ChangeSorter>>uninstallChangeSet (in category 'changeSet menu') ----- - uninstallChangeSet - "Attempt to uninstall the current change set, after confirmation." - - self okToChange ifFalse: [^ self]. - (self confirm: 'Uninstalling a changeSet is unreliable at best. - It will only work if the changeSet consists only of single - changes, additions and removals of methods, and if - no subsequent changes have been to any of them. - No changes to classes will be undone. - The changeSet will be cleared after uninstallation. - Do you still wish to attempt to uninstall this changeSet? translated') - ifFalse: [^ self]. - - myChangeSet uninstall. - self changed: #relabel. - self changed: #classList. - self changed: #messageList. - self setContents. - self contentsChanged.! Item was removed: - ----- Method: ChangeSorter>>unshiftedChangeSetMenu: (in category 'changeSet menu') ----- - unshiftedChangeSetMenu: aMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - <changeSetMenuShifted: false> - Smalltalk isMorphic - ifTrue: - [aMenu title: 'Change Set' translated] - ifFalse: - [aMenu title: 'Change Set: - ' translated , myChangeSet name]. - aMenu addStayUpItemSpecial. - - aMenu add: 'make changes go to me (m)' translated action: #newCurrent. - aMenu addLine. - aMenu add: 'new change set... (n)' translated action: #newSet. - aMenu add: 'find...(f)' translated action: #findCngSet. - aMenu add: 'select change set...' translated action: #chooseCngSet. - aMenu addLine. - aMenu add: 'rename change set (r)' translated action: #rename. - aMenu add: 'file out (o)' translated action: #fileOut. - aMenu add: 'mail to list' translated action: #mailOut. - aMenu add: 'browse methods (b)' translated action: #browseChangeSet. - aMenu add: 'browse change set (B)' translated action: #openChangeSetBrowser. - aMenu addLine. - parent - ifNotNil: - [aMenu add: 'copy all to other side (c)' translated action: #copyAllToOther. - aMenu add: 'submerge into other side' translated action: #submergeIntoOtherSide. - aMenu add: 'subtract other side (-)' translated action: #subtractOtherSide. - aMenu addLine]. - myChangeSet hasPreamble - ifTrue: - [aMenu add: 'edit preamble... (p)' translated action: #editPreamble. - aMenu add: 'remove preamble' translated action: #removePreamble] - ifFalse: [aMenu add: 'add preamble... (p)' translated action: #editPreamble]. - myChangeSet hasPostscript - ifTrue: - [aMenu add: 'edit postscript...' translated action: #editPostscript. - aMenu add: 'remove postscript' translated action: #removePostscript] - ifFalse: [aMenu add: 'add postscript...' translated action: #editPostscript]. - aMenu addLine. - - aMenu add: 'destroy change set (x)' translated action: #remove. - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>unshiftedChangeSetMore: (in category 'changeSet menu') ----- - unshiftedChangeSetMore: aMenu - <changeSetMenuShifted: true> - <menuPriority: 1000> - ^ aMenu addTranslatedList: #( - - - ('more...' offerUnshiftedChangeSetMenu 'Takes you back to the primary change-set menu.')); - yourself! Item was removed: - ----- Method: ChangeSorter>>unshiftedMessageMenu: (in category 'message list') ----- - unshiftedMessageMenu: aMenu - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - <messageListMenuShifted: false> - - aMenu title: 'message list' translated. - aMenu addStayUpItemSpecial. - - parent ifNotNil: - [aMenu addTranslatedList: #( - ('copy method to other side' copyMethodToOther) - ('move method to other side' moveMethodToOther))]. - - aMenu addTranslatedList: #( - ('delete method from changeSet (d)' forget) - - - ('remove method from system (x)' removeMessage) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' spawnHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage) - ('printOut' printOutMessage) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions)). - ^ aMenu! Item was removed: - ----- Method: ChangeSorter>>update (in category 'changeSet menu') ----- - update - "recompute all of my panes" - - self updateIfNecessary. - parent ifNotNil: [(parent other: self) updateIfNecessary]! Item was removed: - ----- Method: ChangeSorter>>updateIfNecessary (in category 'changeSet menu') ----- - updateIfNecessary - "Recompute all of my panes." - - | newList | - self okToChange ifFalse: [^ self]. - - myChangeSet ifNil: [^ self]. "Has been known to happen though shouldn't" - (myChangeSet isMoribund) ifTrue: - [self changed: #changeSetList. - ^ self showChangeSet: ChangeSet current]. - - newList := self changeSetList. - - (priorChangeSetList == nil or: [priorChangeSetList ~= newList]) - ifTrue: - [priorChangeSetList := newList. - self changed: #changeSetList].! Item was removed: - ----- Method: ChangeSorter>>veryDeepFixupWith: (in category 'creation') ----- - veryDeepFixupWith: deepCopier - - super veryDeepFixupWith: deepCopier. - parent := deepCopier references at: parent ifAbsent: [parent]. - self updateIfNecessary! Item was removed: - ----- Method: ChangeSorter>>veryDeepInner: (in category 'creation') ----- - veryDeepInner: deepCopier - "Copy all of my instance variables. Some need to be not copied at all, but shared." - - super veryDeepInner: deepCopier. - "parent := parent. Weakly copied" - "myChangeSet := myChangeSet. Weakly copied" - currentClassName := currentClassName veryDeepCopyWith: deepCopier. - "currentSelector := currentSelector. Symbol" - priorChangeSetList := priorChangeSetList veryDeepCopyWith: deepCopier. - - - ! Item was removed: - ----- Method: ChangeSorter>>wantsAnnotationPane (in category 'code pane') ----- - wantsAnnotationPane - - ^ false! Item was removed: - ----- Method: ChangeSorter>>wantsOptionalButtons (in category 'code pane') ----- - wantsOptionalButtons - "No optional buttons for ChangeSorter" - ^false! Item was removed: - ----- Method: ChangeSorter>>withoutItemAnnotation: (in category 'annotation') ----- - withoutItemAnnotation: aStringOrNil - "return the current item without the package annotation we added on" - | endItemIndex | - aStringOrNil ifNil: [^nil] . - ( endItemIndex := aStringOrNil findString: self beginNote) = 0 - ifTrue: [^ aStringOrNil ] . - ^ aStringOrNil first: endItemIndex - 1! Item was removed: - MessageSet subclass: #ChangedMessageSet - instanceVariableNames: 'changeSet' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !ChangedMessageSet commentStamp: '<historical>' prior: 0! - A ChangedMessageSet is a message set associated with a change-set; it bears an entry for every method added or changed in the change set, as well as for every class-comment of which the change-set bears a note.! Item was removed: - ----- Method: ChangedMessageSet class>>openFor: (in category 'opening') ----- - openFor: aChangeSet - "Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message-list consists of all the methods in aChangeSet. After any method submission, the message list is refigured, making it plausibly dynamic" - - | messageSet | - - messageSet := aChangeSet changedMessageListAugmented select: [ :each | each isValid]. - self - openMessageList: messageSet - name: 'Methods in Change Set ', aChangeSet name - autoSelect: nil - changeSet: aChangeSet! Item was removed: - ----- Method: ChangedMessageSet class>>openMessageList:name:autoSelect:changeSet: (in category 'opening') ----- - openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet - | messageSet | - messageSet := self messageList: messageList. - messageSet changeSet: aChangeSet. - messageSet autoSelectString: autoSelectString; - setInitialLabel: labelString. - ToolBuilder open: messageSet! Item was removed: - ----- Method: ChangedMessageSet>>changeSet: (in category 'initialization') ----- - changeSet: aChangeSet - changeSet := aChangeSet! Item was removed: - ----- Method: ChangedMessageSet>>contents:notifying: (in category 'acceptance') ----- - contents: aString notifying: aController - "Accept the string as new source for the current method, and make certain the annotation pane gets invalidated" - - | existingSelector existingClass superResult newSelector | - existingSelector := self selectedMessageName. - existingClass := self selectedClassOrMetaClass. - - superResult := super contents: aString notifying: aController. - superResult ifTrue: "succeeded" - [newSelector := existingClass newParser parseSelector: aString. - newSelector ~= existingSelector - ifTrue: "Selector changed -- maybe an addition" - [self reformulateList. - self changed: #messageList. - self messageList withIndexDo: - [:aMethodReference :anIndex | - (aMethodReference actualClass == existingClass and: - [aMethodReference methodSymbol == newSelector]) - ifTrue: - [self messageListIndex: anIndex]]]]. - ^ superResult! Item was removed: - ----- Method: ChangedMessageSet>>growable (in category 'message list') ----- - growable - "Answer whether the receiver can be changed by manual additions & deletions" - - ^ false! Item was removed: - ----- Method: ChangedMessageSet>>reformulateList (in category 'reformulation') ----- - reformulateList - "Reformulate the message list of the receiver" - - self initializeMessageList: (changeSet changedMessageListAugmented select: - [:each | each isValid]) - ! Item was removed: - Object subclass: #ChangesOrganizer - instanceVariableNames: '' - classVariableNames: 'ChangeSetNamesInRelease RecentUpdateMarker' - poolDictionaries: '' - category: 'Tools-Changes'! - - !ChangesOrganizer commentStamp: 'cbr 7/27/2010 19:17' prior: 0! - I manage ChangeSets in the system. See the protocols on my class side. - - For an example of what I can do, select the following line in a Workspace and print it. - - - ChangesOrganizer allChangeSetNames! Item was removed: - ----- Method: ChangesOrganizer class>>allChangeSetNames (in category 'enumerating') ----- - allChangeSetNames - ^ ChangeSet allChangeSetNames! Item was removed: - ----- Method: ChangesOrganizer class>>allChangeSets (in category 'enumerating') ----- - allChangeSets - "Return the list of all current ChangeSets" - - ^ChangeSet allChangeSets! Item was removed: - ----- Method: ChangesOrganizer class>>allChangeSetsWithClass:selector: (in category 'enumerating') ----- - allChangeSetsWithClass: class selector: selector - - ^ ChangeSet allChangeSetsWithClass: class selector: selector! Item was removed: - ----- Method: ChangesOrganizer class>>assuredChangeSetNamed: (in category 'services') ----- - assuredChangeSetNamed: aName - "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it." - - ^(self changeSetNamed: aName) - ifNil: - [self basicNewChangeSet: aName]! Item was removed: - ----- Method: ChangesOrganizer class>>basicNewChangeSet: (in category 'adding') ----- - basicNewChangeSet: newName - ^ChangeSet basicNewChangeSet: newName! Item was removed: - ----- Method: ChangesOrganizer class>>belongsInAdditions: (in category 'class initialization') ----- - belongsInAdditions: aChangeSet - "Answer whether a change set belongs in the Additions category, which is fed by all change sets that are neither numbered nor in the initial release" - - ^ (((self belongsInProjectsInRelease: aChangeSet) or: - [self belongsInNumbered: aChangeSet])) not! Item was removed: - ----- Method: ChangesOrganizer class>>belongsInAll: (in category 'class initialization') ----- - belongsInAll: aChangeSet - "Answer whether a change set belongs in the All category" - - ^ true ! Item was removed: - ----- Method: ChangesOrganizer class>>belongsInMyInitials: (in category 'class initialization') ----- - belongsInMyInitials: aChangeSet - "Answer whether a change set belongs in the MyInitials category. " - - ^ aChangeSet name endsWith: ('-', Utilities authorInitials)! Item was removed: - ----- Method: ChangesOrganizer class>>belongsInNumbered: (in category 'class initialization') ----- - belongsInNumbered: aChangeSet - "Answer whether a change set belongs in the Numbered category. " - - ^ aChangeSet name startsWithDigit! Item was removed: - ----- Method: ChangesOrganizer class>>belongsInProjectChangeSets: (in category 'class initialization') ----- - belongsInProjectChangeSets: aChangeSet - "Answer whether a change set belongs in the MyInitials category. " - - ^ aChangeSet belongsToAProject! Item was removed: - ----- Method: ChangesOrganizer class>>belongsInProjectsInRelease: (in category 'class initialization') ----- - belongsInProjectsInRelease: aChangeSet - "Answer whether a change set belongs in the ProjectsInRelease category. You can hand-tweak this to suit your working style. This just covers the space of project names in the 2.9, 3.0, and 3.1a systems" - - | aString | - ^ ((aString := aChangeSet name) beginsWith: 'Play With Me') or: [self changeSetNamesInReleaseImage includes: aString]! Item was removed: - ----- Method: ChangesOrganizer class>>belongsInRecentUpdates: (in category 'class initialization') ----- - belongsInRecentUpdates: aChangeSet - "Answer whether a change set belongs in the RecentUpdates category." - - ^ aChangeSet name startsWithDigit and: - [aChangeSet name asInteger >= self recentUpdateMarker]! Item was removed: - ----- Method: ChangesOrganizer class>>buildAggregateChangeSet (in category 'services') ----- - buildAggregateChangeSet - - ^ ChangeSet buildAggregateChangeSet! Item was removed: - ----- Method: ChangesOrganizer class>>changeSet:containsClass: (in category 'enumerating') ----- - changeSet: aChangeSet containsClass: aClass - | theClass | - theClass := Smalltalk classNamed: aClass. - theClass ifNil: [^ false]. - ^ aChangeSet containsClass: theClass! Item was removed: - ----- Method: ChangesOrganizer class>>changeSetNamed: (in category 'enumerating') ----- - changeSetNamed: aName - "Return the change set of the given name, or nil if none found. 1/22/96 sw" - ^ChangeSet named: aName! Item was removed: - ----- Method: ChangesOrganizer class>>changeSetNamesInReleaseImage (in category 'class initialization') ----- - changeSetNamesInReleaseImage - "Answer a list of names of project change sets that come pre-shipped in the latest sytem release. On the brink of shipping a new release, call 'ChangeSorter noteChangeSetsInRelease' " - - ^ ChangeSetNamesInRelease ifNil: - [ChangeSetNamesInRelease := self changeSetNamesInThreeOh]! Item was removed: - ----- Method: ChangesOrganizer class>>changeSetNamesInThreeOh (in category 'class initialization') ----- - changeSetNamesInThreeOh - "Hard-coded: answer a list of names of project change sets that came pre-shipped in Squeak 3.0" - - ^ #('The Worlds of Squeak' 'Fun with Morphic' 'Games' 'Fun With Music' 'Building with Squeak' 'Squeak and the Internet' 'Squeak in 3D' 'More About Sound' ) ! Item was removed: - ----- Method: ChangesOrganizer class>>changeSetsNamedSuchThat: (in category 'enumerating') ----- - changeSetsNamedSuchThat: nameBlock - ^ChangeSet changeSetsNamedSuchThat: nameBlock! Item was removed: - ----- Method: ChangesOrganizer class>>countOfChangeSetsWithClass:andSelector: (in category 'services') ----- - countOfChangeSetsWithClass: aClass andSelector: aSelector - "Answer how many change sets record a change for the given class and selector" - - ^ (self allChangeSetsWithClass: aClass selector: aSelector) size! Item was removed: - ----- Method: ChangesOrganizer class>>deleteChangeSetsNumberedLowerThan: (in category 'removing') ----- - deleteChangeSetsNumberedLowerThan: anInteger - "Delete all changes sets whose names start with integers smaller than anInteger" - - self removeChangeSetsNamedSuchThat: - [:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]]. - - "ChangesOrganizer deleteChangeSetsNumberedLowerThan: (ChangeSorter highestNumberedChangeSet name initialIntegerOrNil - 500)" - ! Item was removed: - ----- Method: ChangesOrganizer class>>doesAnyChangeSetHaveClass:andSelector: (in category 'services') ----- - doesAnyChangeSetHaveClass: aClass andSelector: aSelector - "Answer whether any known change set bears a change for the given class and selector" - - ^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! Item was removed: - ----- Method: ChangesOrganizer class>>existingOrNewChangeSetNamed: (in category 'enumerating') ----- - existingOrNewChangeSetNamed: aName - ^ChangeSet existingOrNewChangeSetNamed: aName! Item was removed: - ----- Method: ChangesOrganizer class>>fileOutChangeSetsNamed: (in category 'utilities') ----- - fileOutChangeSetsNamed: nameList - "File out the list of change sets whose names are provided" - "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')" - - | notFound empty infoString | - notFound := OrderedCollection new. - empty := OrderedCollection new. - nameList do: - [:aName | | aChangeSet | (aChangeSet := self changeSetNamed: aName) - ifNotNil: - [aChangeSet isEmpty - ifTrue: - [empty add: aName] - ifFalse: - [aChangeSet fileOut]] - ifNil: - [notFound add: aName]]. - - infoString := '{1} change set(s) filed out' translated format: {nameList size - notFound size}. - notFound size > 0 ifTrue: - [infoString := infoString, ' - - ', ('{1} change set(s) not found:' translated format: {notFound size}). - notFound do: - [:aName | infoString := infoString, ' - ', aName]]. - empty size > 0 ifTrue: - [infoString := infoString, ' - ', ('{1} change set(s) were empty:' translated format: {empty size }). - empty do: - [:aName | infoString := infoString, ' - ', aName]]. - - self inform: infoString! Item was removed: - ----- Method: ChangesOrganizer class>>gatherChangeSets (in category 'enumerating') ----- - gatherChangeSets "ChangeSorter gatherChangeSets" - ^ChangeSet gatherChangeSets! Item was removed: - ----- Method: ChangesOrganizer class>>highestNumberedChangeSet (in category 'enumerating') ----- - highestNumberedChangeSet - - ^ ChangeSet highestNumberedChangeSet! Item was removed: - ----- Method: ChangesOrganizer class>>initialize (in category 'class initialization') ----- - initialize - - "Initialize the class variables" - RecentUpdateMarker := 0. - - - ! Item was removed: - ----- Method: ChangesOrganizer class>>mostRecentChangeSetWithChangeForClass:selector: (in category 'enumerating') ----- - mostRecentChangeSetWithChangeForClass: class selector: selector - | hits | - hits := self allChangeSets select: - [:cs | (cs atSelector: selector class: class) ~~ #none]. - hits isEmpty ifTrue: [^ 'not in any change set' translated]. - ^ 'recent cs: {1}' translated format: {hits last name}! Item was removed: - ----- Method: ChangesOrganizer class>>newChangeSet (in category 'adding') ----- - newChangeSet - "Prompt the user for a name, and establish a new change set of - that name (if ok), making it the current changeset. Return nil - of not ok, else return the actual changeset." - - | newName newSet | - newName := Project uiManager - request: 'Please name the new change set:' translated - initialAnswer: ChangeSet defaultName. - newName isEmptyOrNil ifTrue: - [^ nil]. - newSet := self basicNewChangeSet: newName. - newSet ifNotNil: - [ChangeSet newChanges: newSet]. - ^ newSet! Item was removed: - ----- Method: ChangesOrganizer class>>newChangeSet: (in category 'adding') ----- - newChangeSet: aName - "Makes a new change set called aName, add author initials to try to - ensure a unique change set name." - - | newName | - newName := aName , FileDirectory dot , Utilities authorInitials. - ^ self basicNewChangeSet: newName! Item was removed: - ----- Method: ChangesOrganizer class>>newChangesFromStream:named: (in category 'adding') ----- - newChangesFromStream: aStream named: aName - ^ChangeSet newChangesFromStream: aStream named: aName - ! Item was removed: - ----- Method: ChangesOrganizer class>>noteChangeSetsInRelease (in category 'class initialization') ----- - noteChangeSetsInRelease - "Freshly compute what the change sets in the release are; to be called manually just before a release" - - ChangeSetNamesInRelease := (Project allProjects collect: [:p | p name]) asSet asOrderedCollection. - - "ChangeSorter noteChangeSetsInRelease"! Item was removed: - ----- Method: ChangesOrganizer class>>promoteToTop: (in category 'enumerating') ----- - promoteToTop: aChangeSet - "Make aChangeSet the first in the list from now on" - ^ChangeSet promoteToTop: aChangeSet! Item was removed: - ----- Method: ChangesOrganizer class>>recentUpdateMarker (in category 'services') ----- - recentUpdateMarker - "Answer the number representing the threshold of what counts as 'recent' for an update number. This allow you to use the RecentUpdates category in a ChangeSorter to advantage" - - ^ RecentUpdateMarker ifNil: [RecentUpdateMarker := 0]! Item was removed: - ----- Method: ChangesOrganizer class>>recentUpdateMarker: (in category 'services') ----- - recentUpdateMarker: aNumber - "Set the recent update marker as indicated" - - ^ RecentUpdateMarker := aNumber! Item was removed: - ----- Method: ChangesOrganizer class>>removeChangeSet: (in category 'removing') ----- - removeChangeSet: aChangeSet - "Remove the given changeSet. Caller must assure that it's cool to do this" - ^ChangeSet removeChangeSet: aChangeSet! Item was removed: - ----- Method: ChangesOrganizer class>>removeChangeSetsNamedSuchThat: (in category 'removing') ----- - removeChangeSetsNamedSuchThat: nameBlock - (self changeSetsNamedSuchThat: nameBlock) - do: [:cs | self removeChangeSet: cs]! Item was removed: - ----- Method: ChangesOrganizer class>>removeEmptyUnnamedChangeSets (in category 'removing') ----- - removeEmptyUnnamedChangeSets - "Remove all change sets that are empty, whose names start with Unnamed, - and which are not nailed down by belonging to a Project." - "ChangeSorter removeEmptyUnnamedChangeSets" - | toGo | - (toGo := (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) - select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) - do: [:cs | self removeChangeSet: cs]. - self inform: ('{1} change set(s) removed.' translated format: {toGo size}).! Item was removed: - ----- Method: ChangesOrganizer class>>reorderChangeSets (in category 'services') ----- - reorderChangeSets - "Change the order of the change sets to something more convenient: - First come the project changesets that come with the release. These are mostly empty. - Next come all numbered updates. - Next come all remaining changesets - In a ChangeSorter, they will appear in the reversed order." - - "ChangeSorter reorderChangeSets" - - | newHead newMid newTail | - newHead := OrderedCollection new. - newMid := OrderedCollection new. - newTail := OrderedCollection new. - ChangeSet allChangeSets do: - [:aChangeSet | - (self belongsInProjectsInRelease: aChangeSet) - ifTrue: - [newHead add: aChangeSet] - ifFalse: - [(self belongsInNumbered: aChangeSet) - ifTrue: - [newMid add: aChangeSet] - ifFalse: - [newTail add: aChangeSet]]]. - ChangeSet allChangeSets: newHead, newMid, newTail. - Project current wakeUpTopWindow! Item was removed: - ----- Method: ChangesOrganizer class>>secondaryChangeSet (in category 'services') ----- - secondaryChangeSet - ^ChangeSet secondaryChangeSet! Item was removed: - ----- Method: ChangesOrganizer class>>unload (in category 'class initialization') ----- - unload - "Unload the receiver from global registries" - - self environment at: #FileServices ifPresent: [:cl | - cl unregisterFileReader: self]. - self environment at: #Flaps ifPresent: [:cl | - cl unregisterQuadsWithReceiver: self] ! Item was removed: - ----- Method: Character>>defaultLabelForInspector (in category '*Tools-Inspecting-label') ----- - defaultLabelForInspector - "Answer the default label to be used for an Inspector window on the receiver." - - ^ super defaultLabelForInspector, ': code ', self asInteger printString! Item was removed: - ----- Method: CharacterSet>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ CharacterSetInspector! Item was removed: - CollectionInspector subclass: #CharacterSetInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! Item was removed: - ----- Method: CharacterSetInspector>>canAddOrRemoveElements (in category 'private') ----- - canAddOrRemoveElements - - ^ false! Item was removed: - ----- Method: CharacterSetInspector>>characterNameFor: (in category 'private') ----- - characterNameFor: character - "Extracted from Character >> #printOn:." - - ^ String streamContents: [:stream | | integerValue | - ((integerValue := character asInteger) > 32 and: [integerValue ~= 127]) - ifTrue: [ - character printAsLiteralOn: stream. - stream space]. - stream nextPut: $(; print: integerValue; nextPut: $)].! Item was removed: - ----- Method: CharacterSetInspector>>characterValueFor: (in category 'private') ----- - characterValueFor: character - "Extracted from Character >> #printOn: (and #storeOn:)." - - ^ String streamContents: [:stream | - (character class constantNameFor: character) - ifNotNil: [:name | stream nextPutAll: character class name; space; nextPutAll: name] - ifNil: [stream nextPutAll: character class name; nextPutAll: ' value: '; print: character asInteger]].! Item was removed: - ----- Method: CharacterSetInspector>>elementAt: (in category 'menu - private') ----- - elementAt: indexOrKey - "All field keys are characters." - - ^ indexOrKey! Item was removed: - ----- Method: CharacterSetInspector>>elementGetterAt: (in category 'private') ----- - elementGetterAt: character - - self shouldNotImplement.! Item was removed: - ----- Method: CharacterSetInspector>>elementIndices (in category 'private') ----- - elementIndices - - self shouldNotImplement.! Item was removed: - ----- Method: CharacterSetInspector>>elementNameAt: (in category 'private') ----- - elementNameAt: index - - self shouldNotImplement.! Item was removed: - ----- Method: CharacterSetInspector>>elementSetterAt: (in category 'private') ----- - elementSetterAt: index - - self shouldNotImplement.! Item was removed: - ----- Method: CharacterSetInspector>>streamElementsOn: (in category 'fields - streaming') ----- - streamElementsOn: aStream - "Overwritten to realize array representation of character sets if they can be enumerated. Assume that enumeration is deterministic." - - self object canBeEnumerated ifFalse: [^ self]. - - self - streamOn: aStream - truncate: self object asArray "Requires character set to be enumerable." - collectFields: [:character :index | - (self newFieldForType: #element key: index) - name: ('{1}: {2}' format: {index. self characterNameFor: character}); - valueGetter: [:characterSet | self characterValueFor: character]; printValueAsIs; - yourself]! Item was removed: - ----- Method: Class>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Class'! Item was removed: - ----- Method: Class>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ ClassInspector! Item was removed: - VersionsBrowser subclass: #ClassCommentVersionsBrowser - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - - !ClassCommentVersionsBrowser commentStamp: 'asm 8/13/2002 23:20' prior: 0! - A class-comment-versions-browser tool! Item was removed: - ----- Method: ClassCommentVersionsBrowser class>>browseCommentOf: (in category 'instance creation') ----- - browseCommentOf: class - Cursor read showWhile: - [| changeList | - changeList := self new scanVersionsOf: class. - changeList ifNil: [^ self inform: 'No versions available' translated]. - self open: changeList name: ('Recent versions of {1}''s comments' translated format: {class name}) multiSelect: false ] - ! Item was removed: - ----- Method: ClassCommentVersionsBrowser class>>commentRecordsOf: (in category 'utilities') ----- - commentRecordsOf: aClass - "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." - - | aList | - aList := self new - scanVersionsOf: aClass. - ^ aList ifNotNil: [aList changeList]! Item was removed: - ----- Method: ClassCommentVersionsBrowser class>>timeStampFor:class:reverseOrdinal: (in category 'utilities') ----- - timeStampFor: aSelector class: aClass reverseOrdinal: anInteger - "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." - - | aChangeList | - aChangeList := self new scanVersionsOf: aClass. - ^ aChangeList ifNil: [nil] ifNotNil: - [aChangeList list size >= anInteger - ifTrue: - [(aChangeList changeList at: anInteger) stamp] - ifFalse: - [nil]]! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>aboutToStyle: (in category 'contents') ----- - aboutToStyle: aStyler - - ^false! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>classCommentIndicated (in category 'misc') ----- - classCommentIndicated - "Answer whether the receiver is pointed at a class comment" - - ^ true! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>compareToCurrentVersion (in category 'menu') ----- - compareToCurrentVersion - "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" - - ^ self compareToCurrentSource: classOfMethod organization classComment! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>contentsSymbolQuints (in category 'misc') ----- - contentsSymbolQuints - "Answer a list of quintuplets representing information on the alternative views available in the code pane" - - ^ #( - (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') - (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version'))! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.753 g: 0.677 b: 0.9)! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>diffedVersionContents (in category 'basic function') ----- - diffedVersionContents - "Answer diffed version contents, maybe pretty maybe not" - - | change class earlier later | - (listIndex = 0 - or: [changeList size < listIndex]) - ifTrue: [^ '']. - change := changeList at: listIndex. - later := change text. - class := self selectedClass. - (listIndex == changeList size or: [class == nil]) - ifTrue: [^ later]. - - earlier := (changeList at: listIndex + 1) text. - - ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>listSelectionVersionsMenu: (in category 'menu') ----- - listSelectionVersionsMenu: aMenu - - ^ aMenu addTranslatedList: #( - ('compare to current' compareToCurrentVersion 'compare selected version to the current version') - ('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version')); - yourself - ! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>offerVersionsHelp (in category 'menu') ----- - offerVersionsHelp - (StringHolder new contents: self versionsHelpString) - openLabel: 'Class Comment Versions Browsers' translated! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>priorSourceOrNil (in category 'misc') ----- - priorSourceOrNil - "If the currently-selected method has a previous version, return its source, else return nil" - | aClass aSelector changeRecords | - (aClass := self selectedClass) ifNil: [^ nil]. - (aSelector := self selectedMessageName) ifNil: [^ nil]. - changeRecords := self class commentRecordsOf: self selectedClass. - (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. - ^ (changeRecords at: 2) string - ! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>reformulateList (in category 'basic function') ----- - reformulateList - - classOfMethod organization classComment ifNil: [^ self]. - - self scanVersionsOf: classOfMethod. - self changed: #list. "for benefit of mvc" - listIndex := 1. - self changed: #listIndex. - self contentsChanged! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>scanVersionsOf: (in category 'basic function') ----- - scanVersionsOf: class - "Scan for all past versions of the class comment of the given class" - - | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | - - classOfMethod := class. - oldCommentRemoteStr := class organization commentRemoteStr. - currentCompiledMethod := oldCommentRemoteStr. - selectorOfMethod := #Comment. - changeList := OrderedCollection new. - list := OrderedCollection new. - listIndex := 0. - oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. - - sourceFilesCopy := SourceFiles collect: - [:x | x isNil ifTrue: [ nil ] - ifFalse: [x readOnlyCopy]]. - position := oldCommentRemoteStr position. - file := sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. - [position notNil & file notNil] - whileTrue: - [file position: (0 max: position-150). " Skip back to before the preamble" - [file position < (position-1)] "then pick it up from the front" - whileTrue: [preamble := file nextChunk]. - - prevPos := nil. - stamp := ''. - (preamble findString: 'commentStamp:' startingAt: 1) > 0 - ifTrue: [tokens := Scanner new scanTokens: preamble. - (tokens at: tokens size-3) = #commentStamp: - ifTrue: ["New format gives change stamp and unified prior pointer" - stamp := tokens at: tokens size-2. - prevPos := tokens last. - prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. - prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]] - ifFalse: ["The stamp get lost, maybe after a condenseChanges" - stamp := '<historical>' translated]. - - self addItem: - (ChangeRecord new file: file position: position type: #classComment - class: class name category: nil meta: class isMeta stamp: stamp) - text: stamp , ' ' , class name , ' class comment'. - prevPos = 0 ifTrue:[prevPos := nil]. - position := prevPos. - prevPos notNil - ifTrue:[file := sourceFilesCopy at: prevFileIndex]]. - sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. - listSelections := Array new: list size withAll: false! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>selectedClass (in category 'misc') ----- - selectedClass - "Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" - - ^ classOfMethod! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>updateListsAndCodeIn: (in category 'basic function') ----- - updateListsAndCodeIn: aWindow - | aComment | - aComment := classOfMethod organization commentRemoteStr. - aComment == currentCompiledMethod - ifFalse: - ["Do not attempt to formulate if there is no source pointer. - It probably means it has been recompiled, but the source hasn't been written - (as during a display of the 'save text simply?' confirmation)." - aComment last ~= 0 ifTrue: [self reformulateList]]. - ^ true - ! Item was removed: - ----- Method: ClassCommentVersionsBrowser>>wantsPrettyDiffOption (in category 'misc') ----- - wantsPrettyDiffOption - "Answer whether pretty-diffs are meaningful for this tool" - - ^ false! Item was removed: - Inspector subclass: #ClassInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !ClassInspector commentStamp: 'mt 3/30/2020 14:47' prior: 0! - I am an Inspector that is specialized for inspecting Class objects. I show fields for my class variables and the shared pools I use.! Item was removed: - ----- Method: ClassInspector>>streamClassVariablesOn: (in category 'fields - streaming') ----- - streamClassVariablesOn: aStream - - self object classVarNames do: [:name | - aStream nextPut: ((self newFieldForType: #classVar key: name) - shouldStyleName: true; - valueGetter: [:object | object classPool at: name]; - valueSetter: [:object :value | object classPool at: name put: value]; - yourself)]! Item was removed: - ----- Method: ClassInspector>>streamSharedPoolsOn: (in category 'fields - streaming') ----- - streamSharedPoolsOn: aStream - - self object sharedPools withIndexDo: [:pool :index | - aStream nextPut: ((self newFieldForType: #poolDictionary key: (self environment keyAtIdentityValue: pool)) - shouldStyleName: true; - valueGetter: [:object | object sharedPools at: index]; - valueSetter: [:object :value | object sharedPools at: index put: value]; - yourself)].! Item was removed: - ----- Method: ClassInspector>>streamVariableFieldsOn: (in category 'fields - streaming') ----- - streamVariableFieldsOn: aStream - "Add fields for class variables and pool dictionaries." - - super streamVariableFieldsOn: aStream. - self - streamClassVariablesOn: aStream; - streamSharedPoolsOn: aStream.! Item was removed: - HierarchyBrowser subclass: #ClassListBrowser - instanceVariableNames: 'defaultTitle' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !ClassListBrowser commentStamp: 'tpr 10/15/2017 16:46' prior: 0! - A ClassListBrowser displays the code for an arbitrary list of classes. - - ClassListBrowser example1. "all classes that have the string 'Pluggable' in their names" - ClassListBrowser example2. "all classes whose names start with the letter S" - ClassListBrowser example3. "all variable classes" - ClassListBrowser example4. "all classes with more than 100 methods" - ClassListBrowser example5. "all classes that lack class comments" - ClassListBrowser example6. "all classes that have class instance variables" - - ClassListBrowser newOnClassesNamed: #(Browser Boolean) label: 'Browser and Boolean!!'. - ClassListBrowser newOnAllClasses "all classes listed alphabetically" - ! Item was removed: - ----- Method: ClassListBrowser class>>browseClassesSatisfying:title: (in category 'instance creation') ----- - browseClassesSatisfying: classBlock title: aTitle - "Put up a ClassListBrowser showing all classes that satisfy the classBlock." - - self newOnClassesNamed: - (self systemNavigation allClasses select: [:c | (classBlock value: c) == true] - thenCollect: [:c | c name]) - label: aTitle! Item was removed: - ----- Method: ClassListBrowser class>>example1 (in category 'examples') ----- - example1 - "Put up a ClassListBrowser that shows all classes that have the string 'Pluggable' in their names" - - self browseClassesSatisfying: [:cl | cl name includesSubstring: 'Pluggable'] title: 'Pluggables' - - "ClassListBrowser example1" - ! Item was removed: - ----- Method: ClassListBrowser class>>example2 (in category 'examples') ----- - example2 - "Put up a ClassListBrowser that shows all classes whose names start with - the letter S" - - self newOnClassesNamed: (self systemNavigation allClasses - collect: [:c | c name] - thenSelect: [:aName | aName first == $S]) - label: 'All classes starting with S' - "ClassListBrowser example2"! Item was removed: - ----- Method: ClassListBrowser class>>example3 (in category 'examples') ----- - example3 - "Put up a ClassListBrowser that shows all Variable classes" - - self browseClassesSatisfying: [:c | c isVariable] title: 'All Variable classes' - - "ClassListBrowser example3" - ! Item was removed: - ----- Method: ClassListBrowser class>>example4 (in category 'examples') ----- - example4 - "Put up a ClassListBrowser that shows all classes implementing more than 100 methods" - - self browseClassesSatisfying: - [:c | (c selectors size + c class selectors size) > 100] title: 'Classes with more than 100 methods' - - "ClassListBrowser example4" - ! Item was removed: - ----- Method: ClassListBrowser class>>example5 (in category 'examples') ----- - example5 - "Put up a ClassListBrowser that shows all classes that lack class comments" - - self - browseClassesSatisfying: - [:c | c organization classComment isEmptyOrNil] - title: 'Classes lacking class comments' - - "ClassListBrowser example5" - ! Item was removed: - ----- Method: ClassListBrowser class>>example6 (in category 'examples') ----- - example6 - "Put up a ClassListBrowser that shows all classes that have class instance variables" - - self - browseClassesSatisfying: - [:c | c class instVarNames size > 0] - title: - 'Classes that define class-side instance variables' - - "ClassListBrowser example6"! Item was removed: - ----- Method: ClassListBrowser class>>newOnAllClasses (in category 'instance creation') ----- - newOnAllClasses - "Open a browser on all the classes in the system, listed alphabetically" - "NB - what meaning does 'all classes' have in an environment that is not the root? - - what might alphabetic ordering need to do for non-latin languages?" - "ClassListBrowser newOnAllClasses" - - | newBrowser | - - newBrowser := self new. - ^ newBrowser buildAndOpenBrowserLabel: 'All Classes Alphabetically' - ! Item was removed: - ----- Method: ClassListBrowser class>>newOnClassesNamed:label: (in category 'instance creation') ----- - newOnClassesNamed: aListOfClassNames label: aString - "Open a browser on all the classes in the list, set the label to aString since we may need to specify to the user what the list includes" - "ClassListBrowser newOnClassesNamed: #(Browser Boolean) label: 'Browser and Boolean!!'." - | newBrowser | - - newBrowser := self new. - newBrowser initForClassesNamed: aListOfClassNames. - ^ newBrowser buildAndOpenBrowserLabel: aString - ! Item was removed: - ----- Method: ClassListBrowser>>defaultBrowserTitle (in category 'initialization') ----- - defaultBrowserTitle - ^ 'Class List Browser' ! Item was removed: - ----- Method: ClassListBrowser>>defaultTitle: (in category 'title') ----- - defaultTitle: aTitle - "Set the browser's default title" - - defaultTitle := aTitle! Item was removed: - ----- Method: ClassListBrowser>>initAlphabeticListing (in category 'initialization') ----- - initAlphabeticListing - | tab stab index | - self systemOrganizer: SystemOrganization. - metaClassIndicated := false. - classDisplayList := Smalltalk classNames.! Item was removed: - ----- Method: ClassListBrowser>>initForClassesNamed: (in category 'initialization') ----- - initForClassesNamed: nameList - "Initialize the receiver for the class-name-list" - - self systemOrganizer: SystemOrganization. - metaClassIndicated := false. - classDisplayList := nameList copy! Item was removed: - ----- Method: ClassListBrowser>>labelString (in category 'title') ----- - labelString - "Answer the label strilng to use on the browser" - - ^ defaultTitle ifNil: [super labelString]! Item was removed: - ----- Method: ClassListBrowser>>setupIfNotInitialisedYet (in category 'toolbuilder') ----- - setupIfNotInitialisedYet - "ClassListBrowser needs some initialisation to work in the ToolBuilder>build: world since there has to be a list of classes ready to be listed. As a default we use the full list of classes in the system" - - classDisplayList ifNil:[self initAlphabeticListing]! Item was removed: - StringHolder subclass: #CodeHolder - instanceVariableNames: 'currentCompiledMethod contentsSymbol multiWindowState' - classVariableNames: 'ContentsSymbolQuints EditContentsOptions MultiWindowBrowsers' - poolDictionaries: '' - category: 'Tools-Base'! - - !CodeHolder commentStamp: '<historical>' prior: 0! - An ancestor class for all models which can show code. Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.! Item was removed: - ----- Method: CodeHolder class>>addContentsSymbolQuint:afterEntry: (in category 'controls') ----- - addContentsSymbolQuint: quint afterEntry: aSymbol - "Register a menu selection item in the position after the entry with - selection symbol aSymbol." - - "CodeHolder - addContentsSymbolQuint: #(#altSyntax #toggleAltSyntax #showingAltSyntaxString 'altSyntax' 'alternative syntax') - afterEntry: #colorPrint" - - (ContentsSymbolQuints - anySatisfy: [:e | (e isKindOf: Collection) and: [e first = quint first]]) - ifFalse: [ - | entry | - entry := ContentsSymbolQuints - detect: [:e | (e isKindOf: Collection) and: [e first = aSymbol]]. - ContentsSymbolQuints add: quint after: entry. - ^ self]. - self notify: 'entry already exists for ', quint first! Item was removed: - ----- Method: CodeHolder class>>addContentsSymbolQuint:afterPosition: (in category 'controls') ----- - addContentsSymbolQuint: quint afterPosition: index - "Register a menu selection item in the position after index." - - "CodeHolder - addContentsSymbolQuint: #(#altSyntax #toggleAltSyntax #showingAltSyntaxString 'altSyntax' 'alternative syntax') - afterPosition: 1" - - | entry | - entry := ContentsSymbolQuints at: index. - self contentsSymbolQuints add: quint after: entry! Item was removed: - ----- Method: CodeHolder class>>addEditContentsOption: (in category 'controls') ----- - addEditContentsOption: anAssociation - - "CodeHolder addEditContentsOption: #translateToC -> #selectedTranslateToC" - - EditContentsOptions add: anAssociation! Item was removed: - ----- Method: CodeHolder class>>canUseMultiWindowBrowsers (in category 'preferences') ----- - canUseMultiWindowBrowsers - "This is a hook to allow browsers to control whether to respond to the muli-window preference. - Currenty CodeHolder cannot usefully use multi-windows, but may be able to do so in the future." - ^false! Item was removed: - ----- Method: CodeHolder class>>defaultContentsSymbolQuints (in category 'controls') ----- - defaultContentsSymbolQuints - "Default list of quintuplets representing information on the alternative views available in the code pane - first element: the contentsSymbol used - second element: the selector to call when this item is chosen. - third element: the selector to call to obtain the wording of the menu item. - fourth element: the wording to represent this view - fifth element: balloon help - A hypen indicates a need for a seperator line in a menu of such choices" - - ^ { - {#source - . #togglePlainSource - . #showingPlainSourceString - . 'source' - . 'the textual source code as written' translated} . - {#documentation - . #toggleShowDocumentation - . #showingDocumentationString - . 'documentation' - . 'the first comment in the method' translated} . - - #- . - {#prettyPrint - . #togglePrettyPrint - . #prettyPrintString - . 'prettyPrint' - . 'the method source presented in a standard text format' translated} . - - #- . - {#showDiffs - . #toggleRegularDiffing - . #showingRegularDiffsString - . 'showDiffs' - . 'the textual source diffed from its prior version' translated} . - - #- . - {#decompile - . #toggleDecompile - . #showingDecompileString - . 'decompile' - . 'source code decompiled from byteCodes' translated} . - {#byteCodes - . #toggleShowingByteCodes - . #showingByteCodesString - . 'byteCodes' - . 'the bytecodes that comprise the compiled method' translated} . - }! Item was removed: - ----- Method: CodeHolder class>>defaultEditContentsOptions (in category 'controls') ----- - defaultEditContentsOptions - "An array of associations of current display mode symbol to selector - that creates the edit contents for that display mode. The default selector - is #selectedMessage; this is a list of alternative to the default." - - ^ { - #byteCodes -> #selectedBytecodes - }! Item was removed: - ----- Method: CodeHolder class>>initialize (in category 'class initialization') ----- - initialize - - "CodeHolder initialize" - - ContentsSymbolQuints := self defaultContentsSymbolQuints asOrderedCollection. - EditContentsOptions := Dictionary new. - self defaultEditContentsOptions - do: [:opt | EditContentsOptions at: opt key put: opt value]! Item was removed: - ----- Method: CodeHolder class>>removeContentsSymbol: (in category 'controls') ----- - removeContentsSymbol: aSymbol - "Unregister the menu selection item with selection symbol aSymbol." - - "CodeHolder removeContentsSymbol: #altSyntax" - - | entries | - entries := ContentsSymbolQuints - select: [:e | (e isKindOf: Collection) and: [e first = aSymbol]]. - ContentsSymbolQuints removeAll: entries. - ^ entries - ! Item was removed: - ----- Method: CodeHolder class>>useMultiWindowBrowsers (in category 'preferences') ----- - useMultiWindowBrowsers - <preference: 'Multi-window browsers' - category: 'browsing' - description: 'When enabled, the browser uses a multi-window to conserve real-estate. e.g. enable then click in the window label of a browser to see the items being browsed.' - type: #Boolean> - ^MultiWindowBrowsers ifNil: [false]! Item was removed: - ----- Method: CodeHolder class>>useMultiWindowBrowsers: (in category 'preferences') ----- - useMultiWindowBrowsers: aBoolean - MultiWindowBrowsers := aBoolean! Item was removed: - ----- Method: CodeHolder>>aboutToStyle: (in category 'code pane') ----- - aboutToStyle: aStyler - - currentCompiledMethod ifNil: [^ false]. - self isModeStyleable ifFalse: [^ false]. - aStyler classOrMetaClass: self selectedClassOrMetaClass. - ^ true! Item was removed: - ----- Method: CodeHolder>>addModelItemsToWindowMenu: (in category 'misc') ----- - addModelItemsToWindowMenu: aMenu - "Add model-related item to the window menu" - - super addModelItemsToWindowMenu: aMenu. - Smalltalk isMorphic ifTrue: - [aMenu addLine. - aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu]! Item was removed: - ----- Method: CodeHolder>>addPriorVersionsCountForSelector:ofClass:to: (in category 'annotation') ----- - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "add an annotation detailing the prior versions count" - | versionsCount | - - versionsCount := VersionsBrowser versionCountForSelector: aSelector class: aClass. - aStream nextPutAll: - ((versionsCount > 1 - ifTrue: - [versionsCount = 2 ifTrue: - ['1 prior version'] - ifFalse: - [versionsCount printString, ' prior versions']] - ifFalse: - ['no prior versions']), self annotationSeparator)! Item was removed: - ----- Method: CodeHolder>>adoptMessageInCurrentChangeset (in category 'commands') ----- - adoptMessageInCurrentChangeset - "Add the receiver's method to the current change set if not already there" - - self setClassAndSelectorIn: [:cl :sel | - cl ifNotNil: - [ChangeSet current adoptSelector: sel forClass: cl. - self changed: #annotation]] - ! Item was removed: - ----- Method: CodeHolder>>annotation (in category 'annotation') ----- - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - - ((aSelector := self selectedMessageName) == nil or: [(aClass := self selectedClassOrMetaClass) == nil]) ifTrue: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! Item was removed: - ----- Method: CodeHolder>>annotation: (in category 'annotation') ----- - annotation: aString - "The user accepted aString in our annotation pane. Return false because by default we cannot edit annotations" - ^ false - ! Item was removed: - ----- Method: CodeHolder>>annotationForClassCommentFor: (in category 'annotation') ----- - annotationForClassCommentFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the clas comment of the given class." - - | aStamp nonMeta | - aStamp := (nonMeta := aClass theNonMetaClass) organization commentStamp. - ^ aStamp - ifNil: - [nonMeta name, ' has no class comment'] - ifNotNil: - ['class comment for ', nonMeta name, - (aStamp = '<historical>' - ifFalse: - [' - ', aStamp] - ifTrue: - [''])]! Item was removed: - ----- Method: CodeHolder>>annotationForClassDefinitionFor: (in category 'annotation') ----- - annotationForClassDefinitionFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - - | annotation | - annotation := 'Class definition for ', aClass name. - (self annotationRequests includes: #package) ifTrue: - [Environment current packageOrganizer ifNotNil: - [:organizer| - (organizer - packageOfClass: aClass - ifNone: nil) ifNotNil: - [:package| annotation := annotation, ' in package ', package name]]]. - ^annotation! Item was removed: - ----- Method: CodeHolder>>annotationForHierarchyFor: (in category 'annotation') ----- - annotationForHierarchyFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class." - - ^ 'Hierarchy for ', aClass name! Item was removed: - ----- Method: CodeHolder>>annotationForSelector:ofClass: (in category 'annotation') ----- - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - | separator aStream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - aSelector == #Hierarchy - ifTrue: [^ self annotationForHierarchyFor: aClass]. - aStream := (String new: 512) writeStream. - requestList := self annotationRequests. - separator := requestList size > 1 - ifTrue: [self annotationSeparator] - ifFalse: ['']. - requestList - do: [:aRequest | | aString sendersCount aComment aCategory implementorsCount aList stamp authorInitials | - aRequest == #firstComment - ifTrue: [aComment := aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [aStream nextPutAll: aComment; nextPutAll: separator]]. - aRequest == #masterComment - ifTrue: [aComment := aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [aStream nextPutAll: aComment; nextPutAll: separator]]. - aRequest == #documentation - ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [aStream nextPutAll: aComment; nextPutAll: separator]]. - aRequest == #timeStamp - ifTrue: [stamp := self timeStamp. - aStream - nextPutAll: (stamp size > 0 - ifTrue: [stamp] - ifFalse: ['no timeStamp']); - nextPutAll: separator]. - aRequest == #author - ifTrue: [authorInitials := self timeStamp - findTokens ifEmpty: [''] ifNotEmpty: [:tokens | tokens first]. - aStream - nextPutAll: (SystemNavigation authorsInverted - at: authorInitials - ifPresent: [:fullNames | fullNames anyOne] - ifAbsent: ['unknown author']); - nextPutAll:separator]. - aRequest == #messageCategory - ifTrue: [aCategory := aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - aStream nextPutAll: aCategory; nextPutAll: separator]]. - aRequest == #sendersCount - ifTrue: [sendersCount := (self systemNavigation allCallsOn: aSelector) size. - sendersCount := sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - aStream nextPutAll: sendersCount; nextPutAll: separator]. - aRequest == #implementorsCount - ifTrue: [implementorsCount := self systemNavigation numberOfImplementorsOf: aSelector. - implementorsCount := implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - aStream nextPutAll: implementorsCount; nextPutAll: separator]. - aRequest == #priorVersionsCount - ifTrue: [self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: aStream]. - aRequest == #priorTimeStamp - ifTrue: [stamp := VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [aStream nextPutAll: 'prior time stamp: '; nextPutAll: stamp; nextPutAll: separator]]. - aRequest == #recentChangeSet - ifTrue: [aString := ChangesOrganizer mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. - aString size > 0 - ifTrue: [aStream nextPutAll: aString; nextPutAll: separator]]. - aRequest == #allChangeSets - ifTrue: [aList := ChangesOrganizer allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [aStream nextPutAll: 'only in change set '] - ifFalse: [aStream nextPutAll: 'in change sets: ']. - aList - do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']] - ifFalse: [aStream nextPutAll: 'in no change set']. - aStream nextPutAll: separator]. - aRequest == #package - ifTrue: [Environment current packageOrganizer ifNotNil: - [:organizer| - (organizer - packageOfMethod: (MethodReference class: aClass selector: aSelector environment: aClass environment) - ifNone: nil) ifNotNil: - [:package| aStream nextPutAll: 'in package '; nextPutAll: package name; nextPutAll: separator]]]]. - ^ aStream contents! Item was removed: - ----- Method: CodeHolder>>annotationFrame (in category 'toolbuilder') ----- - annotationFrame - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 1 offset: self annotationPaneHeight negated; - rightFraction: 1 offset: 0; - bottomFraction: 1 offset: 0! Item was removed: - ----- Method: CodeHolder>>annotationPaneHeight (in category 'toolbuilder') ----- - annotationPaneHeight - ^ ToolBuilder default inputFieldHeight! Item was removed: - ----- Method: CodeHolder>>annotationPaneMenu:shifted: (in category 'annotation') ----- - annotationPaneMenu: aMenu shifted: shifted - - ^ aMenu - labels: 'change pane size' - lines: #() - selections: #(toggleAnnotationPaneSize)! Item was removed: - ----- Method: CodeHolder>>annotationRequests (in category 'annotation') ----- - annotationRequests - ^ Preferences defaultAnnotationRequests! Item was removed: - ----- Method: CodeHolder>>annotationSeparator (in category 'annotation') ----- - annotationSeparator - "Answer the separator to be used between annotations" - - ^ ' · '! Item was removed: - ----- Method: CodeHolder>>browseImplementors (in category 'commands') ----- - browseImplementors - "Create and schedule a message set browser on all implementors of the currently selected message selector. If there is no message currently selected, offer a type-in" - - self sendQuery: #browseAllImplementorsOf:requestor: to: self with: #(modelMenu).! Item was removed: - ----- Method: CodeHolder>>browseSenders (in category 'commands') ----- - browseSenders - "Create and schedule a message set browser on all senders of the currently selected message selector. If there is no message currently selected, offer a type-in" - - self sendQuery: #browseAllCallsOn:requestor: to: self with: #(modelMenu).! Item was removed: - ----- Method: CodeHolder>>buildAnnotationPaneWith: (in category 'toolbuilder') ----- - buildAnnotationPaneWith: builder - - | annoSpec | - annoSpec := builder pluggableInputFieldSpec new. - annoSpec - model: self; - plainTextOnly: true; - getText: #annotation; - setText: #annotation:. - ^ annoSpec! Item was removed: - ----- Method: CodeHolder>>buildClassBrowserEditString: (in category 'construction') ----- - buildClassBrowserEditString: classDefinition - "Create and schedule a new class browser for the current selection, with initial textual contents set to aString. This is used specifically in spawning where a class is established but a method-category is not." - - self flag: #uglyHack. "mt: We should not abuse Browser like this. We should not even know about #Browser in this superclass." - ^(Browser - newOnClass: self selectedClassOrMetaClass - editString: classDefinition - label: 'Class Browser: ', self selectedClassOrMetaClass name) - editSelection: #editClass; "...because we know it is class def code." - changed: #editString with: classDefinition; "...trigger re-styling." - yourself - ! Item was removed: - ----- Method: CodeHolder>>buildCodePaneWith: (in category 'toolbuilder') ----- - buildCodePaneWith: builder - | textSpec top buttonSpec annoSpec | - self wantsOptionalButtons ifTrue: [ - top := builder pluggablePanelSpec new. - top name: #codePane. - top children: OrderedCollection new. - buttonSpec := self buildOptionalButtonsWith: builder. - buttonSpec frame: self optionalButtonsFrame. - top children add: buttonSpec]. - textSpec := builder pluggableCodePaneSpec new. - textSpec - model: self; - getText: #contents; - setText: #contents:notifying:; - selection: #contentsSelection; - menu: #codePaneMenu:shifted:. - self wantsAnnotationPane ifTrue: [ - top ifNil: [ - top := builder pluggablePanelSpec new. - top children: OrderedCollection new]. - annoSpec := self buildAnnotationPaneWith: builder. - annoSpec frame: self annotationFrame. - top children add: annoSpec]. - top ifNotNil: [ - textSpec frame: self textFrame. - top children add: textSpec]. - ^top ifNil: [textSpec]! Item was removed: - ----- Method: CodeHolder>>buildCodeProvenanceButtonWith: (in category 'toolbuilder') ----- - buildCodeProvenanceButtonWith: builder - | buttonSpec | - buttonSpec := builder pluggableActionButtonSpec new. - buttonSpec - model: self; - label: #codePaneProvenanceString; - changeLabelWhen: #contents; - style: #menuButton; - action: #offerWhatToShowMenu; - help: 'Governs what view is shown in the code pane. Click here to change the view'; - margin: (5 at 0 corner: 0 at 0). - ^buttonSpec! Item was removed: - ----- Method: CodeHolder>>buildMessageBrowserEditString: (in category 'construction') ----- - buildMessageBrowserEditString: aString - "Create and schedule a new message browser for the current selection, - with initial textual contents set to aString." - ^ Browser - newOnClass: self selectedClassOrMetaClass - messageCategory: self categoryOfCurrentMethod - selector: self selectedMessageName - editString: aString - label: 'Message Browser: ' , self selectedClassOrMetaClass name , self categoryOfCurrentMethod! Item was removed: - ----- Method: CodeHolder>>buildMessageCategoryBrowserForCategory:class:selector:editString: (in category 'construction') ----- - buildMessageCategoryBrowserForCategory: aCategory class: aClass selector: aSelectorOrNil editString: methodSourceCode - "Create and schedule a new class browser for the current selection, - with initial textual contents set to aString. This is used specifically in - spawning where a class is established but a method-category is not." - - self flag: #uglyHack. "mt: We should not abuse Browser like this. We should not even know about #Browser in this superclass." - ^ (Browser - newOnClass: aClass - messageCategory: aCategory - selector: aSelectorOrNil - editString: methodSourceCode - label: 'Message category Browser: ' , aClass name , aCategory)! Item was removed: - ----- Method: CodeHolder>>buildMorphicCodePaneWith: (in category 'construction') ----- - buildMorphicCodePaneWith: editString - "Construct the pane that shows the code. - Respect the Preference for standardCodeFont." - - | codePane | - codePane := PluggableTextMorph - on: self - text: #contents - accept: #contents:notifying: - readSelection: #contentsSelection - menu: #codePaneMenu:shifted:. - codePane font: Preferences standardCodeFont. - editString - ifNotNil: [codePane editString: editString. - codePane hasUnacceptedEdits: true]. - ^ codePane! Item was removed: - ----- Method: CodeHolder>>buildOptionalButtonsWith: (in category 'toolbuilder') ----- - buildOptionalButtonsWith: builder - - | panelSpec | - panelSpec := builder pluggablePanelSpec new. - panelSpec children: OrderedCollection new. - self optionalButtonPairs do:[:spec| - | buttonSpec | - buttonSpec := builder pluggableActionButtonSpec new. - buttonSpec model: self. - buttonSpec label: spec first. - buttonSpec action: spec second. - spec second == #methodHierarchy - ifTrue:[buttonSpec - enabled: #inheritanceButtonEnabled; - color: #inheritanceButtonColor]. - spec second == #browseVersions - ifTrue:[buttonSpec enabled: #versionsButtonEnabled]. - spec size > 2 ifTrue:[buttonSpec help: spec third]. - panelSpec children add: buttonSpec]. - - "What to show" - self wantsCodeProvenanceButton ifTrue: [ - panelSpec children - add: builder pluggableSpacerSpec new; - add: (self buildCodeProvenanceButtonWith: builder)]. - - panelSpec layout: #horizontal. "buttons" - ^panelSpec! Item was removed: - ----- Method: CodeHolder>>buttonHeight (in category 'toolbuilder') ----- - buttonHeight - ^ ToolBuilder default buttonRowHeight! Item was removed: - ----- Method: CodeHolder>>canShowMultipleMessageCategories (in category 'message category functions') ----- - canShowMultipleMessageCategories - "Answer whether the receiver is capable of showing multiple message categories" - - ^ false! Item was removed: - ----- Method: CodeHolder>>categoryFromUserWithPrompt:for: (in category 'categories') ----- - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - | labels myCategories reject lines newName menuIndex | - labels := OrderedCollection with: 'new...'. - labels addAll: (myCategories := aClass organization categories sorted: - [: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 | - cats := cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: - [lines add: labels size. - labels addAll: (cats sort: - [:a :b | a asLowercase < b asLowercase]). - reject addAll: cats]]. - - newName := (labels size = 1 or: - [menuIndex := (UIManager default chooseFrom: labels lines: lines title: aPrompt). - menuIndex = 0 ifTrue: [^ nil]. - menuIndex = 1]) - ifTrue: - [UIManager default request: 'Please type new category name' - initialAnswer: 'category name'] - ifFalse: - [labels at: menuIndex]. - ^ newName ifNotNil: [newName asSymbol]! Item was removed: - ----- Method: CodeHolder>>categoryOfCurrentMethod (in category 'categories') ----- - categoryOfCurrentMethod - "Answer the category that owns the current method. If unable to determine a category, answer nil." - - | aClass aSelector | - ^ (aClass := self selectedClassOrMetaClass) - ifNotNil: [(aSelector := self selectedMessageName) - ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! Item was removed: - ----- Method: CodeHolder>>changeCategory (in category 'categories') ----- - changeCategory - "Present a menu of the categories of messages for the current class, - and let the user choose a new category for the current message" - - | aClass aSelector | - (aClass := self selectedClassOrMetaClass) ifNotNil: - [(aSelector := self selectedMessageName) ifNotNil: - [(self letUserReclassify: aSelector in: aClass) ifTrue: - ["ChangeSet current reorganizeClass: aClass." - "Decided on further review that the above, when present, could cause more - unexpected harm than good" - self methodCategoryChanged]]]! Item was removed: - ----- Method: CodeHolder>>codePaneProvenanceString (in category 'controls') ----- - codePaneProvenanceString - "Answer a string that reports on code-pane-provenance" - - | symsAndWordings | - (symsAndWordings := self contentsSymbolQuints) do: - [:aQuad | - contentsSymbol == aQuad first ifTrue: [^ aQuad fourth]]. - ^ symsAndWordings first fourth "default to plain source, for example if nil as initially"! Item was removed: - ----- Method: CodeHolder>>commentContents (in category 'contents') ----- - commentContents - "documentation for the selected method" - - | poss aClass aSelector | - ^ (poss := (aClass := self selectedClassOrMetaClass) - ifNil: - ['----'] - ifNotNil: - [(aSelector := self selectedMessageName) - ifNil: - ['---'] - ifNotNil: - [(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp" - "which however misses comments that are between the temps declaration and the body of the method; those are picked up by ·aClass commentOrInheritedCommentFor: aSelector· but that method will get false positives from comments *anywhere* in the method source"]]) - isEmptyOrNil - ifTrue: - [aSelector - ifNotNil: - [((aClass methodHeaderFor: aSelector), ' - - Has no comment') asText makeSelectorBoldIn: aClass] - ifNil: - ['Hamna']] - ifFalse: [aSelector - ifNotNil: [((aClass methodHeaderFor: aSelector), ' - - ', poss) asText makeSelectorBoldIn: aClass] - ifNil: [poss]]! Item was removed: - ----- Method: CodeHolder>>compileMessage:notifying: (in category 'code pane') ----- - compileMessage: aString notifying: aController - "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." - - | selectedMessageName selector category selectedClassOrMetaClass | - selectedMessageName := self selectedMessageName. - selectedClassOrMetaClass := self selectedClassOrMetaClass. - contents := nil. - selector := (selectedClassOrMetaClass newParser parseSelector: aString). - (self metaClassIndicated - and: [(selectedClassOrMetaClass includesSelector: selector) not - and: [Metaclass isScarySelector: selector]]) - ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses" - (self confirm: ((selector , ' is used in the existing class system. - Overriding it could cause serious problems. - Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size)) - ifFalse: [^nil]]. - category := self selectedMessageCategoryName. - selector := selectedClassOrMetaClass - compile: aString - classified: category - notifying: aController. - selector == nil ifTrue: [^ nil]. - contents := aString copy. - currentCompiledMethod := selectedClassOrMetaClass compiledMethodAt: selector. - ^ true! Item was removed: - ----- Method: CodeHolder>>contents (in category 'contents') ----- - contents - "Answer the source code or documentation for the selected method" - - self showingByteCodes ifTrue: - [^ self selectedBytecodes]. - - self showingDocumentation ifTrue: - [^ self commentContents]. - - ^ self selectedMessage! Item was removed: - ----- Method: CodeHolder>>contents:notifying: (in category 'accessing') ----- - contents: input notifying: aController - "The retrieved information has changed and its source must now be updated. Answer the result of updating the source." - - self changed: #annotation. - - ^ self okayToAccept - ifFalse: [false] - ifTrue: [self compileMessage: input asText notifying: aController].! Item was removed: - ----- Method: CodeHolder>>contentsChanged (in category 'contents') ----- - contentsChanged - - super contentsChanged. - self changed: #annotation! Item was removed: - ----- Method: CodeHolder>>contentsSymbol (in category 'contents') ----- - contentsSymbol - "Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source. A nil value in the contentsSymbol slot will be set to #source by this method" - - ^ contentsSymbol ifNil: - [contentsSymbol := SystemBrowser browseWithPrettyPrint - ifTrue: - [#prettyPrint] - ifFalse: - [#source]]! Item was removed: - ----- Method: CodeHolder>>contentsSymbol: (in category 'contents') ----- - contentsSymbol: aSymbol - "Set the contentsSymbol as indicated. #source means to show source code, #comment means to show the first comment found in the source code" - - contentsSymbol := aSymbol! Item was removed: - ----- Method: CodeHolder>>contentsSymbolQuints (in category 'controls') ----- - contentsSymbolQuints - "Answer a list of quintuplets representing information on the alternative views available in the code pane - first element: the contentsSymbol used - second element: the selector to call when this item is chosen. - third element: the selector to call to obtain the wording of the menu item. - fourth element: the wording to represent this view - fifth element: balloon help - A hypen indicates a need for a seperator line in a menu of such choices" - - ^ ContentsSymbolQuints! Item was removed: - ----- Method: CodeHolder>>copyUpOrCopyDown (in category 'commands') ----- - copyUpOrCopyDown - "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." - - | aClass aSelector allClasses implementors aMenu | - Smalltalk isMorphic ifFalse: [^ self inform: - 'Sorry, for the moment you have to be in - Morphic to use this feature.']. - - ((aClass := self selectedClassOrMetaClass) isNil or: [(aSelector := self selectedMessageName) == nil]) - ifTrue: [^ Beeper beep]. - - allClasses := self systemNavigation hierarchyOfClassesSurrounding: aClass. - implementors := self systemNavigation hierarchyOfImplementorsOf: aSelector forClass: aClass. - aMenu := MenuMorph new defaultTarget: self. - aMenu title: - aClass name, '.', aSelector, ' - Choose where to insert a copy of this method - (blue = current, black = available, red = other implementors'. - allClasses do: - [:cl | - | aColor | - aColor := cl == aClass - ifTrue: [#blue] - ifFalse: - [(implementors includes: cl) - ifTrue: [#red] - ifFalse: [#black]]. - (aColor == #red) - ifFalse: - [aMenu add: cl name selector: #spawnToClass: argument: cl] - ifTrue: - [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. - aMenu lastItem color: (Color colorFrom: aColor)]. - aMenu popUpInWorld! Item was removed: - ----- Method: CodeHolder>>decompiledSourceIntoContents (in category 'message list') ----- - decompiledSourceIntoContents - "For backwards compatibility." - - ^self decompiledSourceIntoContentsWithTempNames: (Sensor leftShiftDown not) - ! Item was removed: - ----- Method: CodeHolder>>decompiledSourceIntoContentsWithTempNames: (in category 'message list') ----- - decompiledSourceIntoContentsWithTempNames: showTempNames - "Obtain a source string by decompiling the method's code, and place - that source string into my contents. - Also return the string. - Get temps from source file if showTempNames is true." - - | class selector method | - class := self selectedClassOrMetaClass. - selector := self selectedMessageName. - "Was method deleted while in another project?" - method := class compiledMethodAt: selector ifAbsent: [^ '']. - - currentCompiledMethod := method. - contents := (showTempNames - ifTrue: [method decompileWithTemps] - ifFalse: [method decompile]) decompileString. - contents := contents asText makeSelectorBoldIn: class. - ^ contents copy! Item was removed: - ----- Method: CodeHolder>>decorateButtons (in category 'controls') ----- - decorateButtons - "Change screen feedback for any buttons in the UI of the receiver that may wish it. Initially, it is only the Inheritance button that is decorated, but one can imagine others." - self changed: #inheritanceButtonColor. - self changed: #inheritanceButtonEnabled. - self changed: #versionsButtonEnabled.! Item was removed: - ----- Method: CodeHolder>>defaultBrowserTitle (in category 'initialize-release') ----- - defaultBrowserTitle - - ^ 'Source Code'! Item was removed: - ----- Method: CodeHolder>>defaultDiffsSymbol (in category 'diffs') ----- - defaultDiffsSymbol - "Answer the code symbol to use when generically switching to diffing" - - ^ Preferences diffsWithPrettyPrint - ifTrue: - [#prettyDiffs] - ifFalse: - [#showDiffs]! Item was removed: - ----- Method: CodeHolder>>didCodeChangeElsewhere (in category 'self-updating') ----- - didCodeChangeElsewhere - "Determine whether the code for the currently selected method and class has been changed somewhere else." - | aClass aSelector aCompiledMethod | - currentCompiledMethod ifNil: [^ false]. - - (aClass := self selectedClassOrMetaClass) ifNil: [^ false]. - - (aSelector := self selectedMessageName) ifNil: [^ false]. - - self classCommentIndicated - ifTrue: [^ currentCompiledMethod ~~ aClass organization commentRemoteStr]. - - ^ (aCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod - and: [aCompiledMethod last ~= 0 "either not yet installed" - or: [ currentCompiledMethod last = 0 "or these methods don't have source pointers"]]! Item was removed: - ----- Method: CodeHolder>>diffFromPriorSourceFor: (in category 'diffs') ----- - diffFromPriorSourceFor: sourceCode - "If there is a prior version of source for the selected method, return a diff, else just return the source code" - - | prior | - ^ (prior := self priorSourceOrNil) - ifNil: [sourceCode] - ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass prettyDiffs: self showingPrettyDiffs]! Item was removed: - ----- Method: CodeHolder>>doItReceiver (in category 'accessing') ----- - doItReceiver - "If there is an instance associated with me, answer it, for true mapping of self. If not, then do what other code-bearing tools do, viz. give access to the class vars." - - ^ self selectedClass! Item was removed: - ----- Method: CodeHolder>>editContents (in category 'contents') ----- - editContents - - ^ self editContentsWithDefault: [self selectedMessage] - ! Item was removed: - ----- Method: CodeHolder>>editContentsWithDefault: (in category 'contents') ----- - editContentsWithDefault: aBlock - - | selector | - selector := EditContentsOptions - at: self contentsSymbol - ifAbsent: [^ aBlock value]. - ^ self perform: selector - ! Item was removed: - ----- Method: CodeHolder>>exploreMethod (in category 'message functions') ----- - exploreMethod - (self selectedClassOrMetaClass - compiledMethodAt: self selectedMessageName - ifAbsent: []) ifNotNil: - [:method| method explore]! Item was removed: - ----- Method: CodeHolder>>formattedLabel: (in category 'message list') ----- - formattedLabel: aString - "Usually, the label is the same as the selector. Override this if the external representation of a message is different from its internal one." - - ^ self - formattedLabel: aString - forSelector: aString - inClass: self selectedClassOrMetaClass! Item was removed: - ----- Method: CodeHolder>>formattedLabel:forSelector:inClass: (in category 'message list') ----- - formattedLabel: aString forSelector: aSymbol inClass: aClass - "Show deprecated messages differently so that users recognize them quickly to avoid them. This is a performance critical method in the user interface." - - self flag: #investigate. "mt: aClass must never be nil!! Faulty tools should override this call themselves or fix the caller site." - aClass ifNil: [^ aString]. - - (aSymbol = #Definition or: [aSymbol = #Comment]) - ifTrue: [aClass isDeprecated - ifFalse: [^ aString]] - ifFalse: [(aClass isDeprecated or: [(aClass compiledMethodAt: aSymbol ifAbsent: [^ aString]) isDeprecated]) - ifFalse: [^ aString]]. - - ^ aString asText addAttributesForDeprecation! Item was removed: - ----- Method: CodeHolder>>getSelectorAndSendQuery:to: (in category 'misc') ----- - getSelectorAndSendQuery: querySelector to: queryPerformer - "See commentary in #getSelectorAndSendQuery:to:with:." - - ^ self getSelectorAndSendQuery: querySelector to: queryPerformer with: {}! Item was removed: - ----- Method: CodeHolder>>getSelectorAndSendQuery:to:with: (in category 'misc') ----- - getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs - "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments." - - ^ self selectedMessageName - ifNotNil: [ "We have a message. Let the user choose a symbol from its contents." - self selectMessageAndEvaluate: [ :aSymbol | - queryPerformer - perform: querySelector - withArguments: {aSymbol}, queryArgs ]] - ifNil: [ "No message currently selected. Obtain a selector from a user type-in." - (Project uiManager request: 'Type selector:' initialAnswer: 'flag:') - ifEmpty: [ nil "Cancelled by user" ] - ifNotEmpty: [ :typeIn | | selectorString | - (Symbol lookup: (selectorString := typeIn asLegalSelector)) - ifNil: [ self inform: 'There is no symbol known as #', selectorString ] - ifNotNil: [ :aSymbol | - queryPerformer - perform: querySelector - withArguments: {aSymbol}, queryArgs ] ]]! Item was removed: - ----- Method: CodeHolder>>informPossiblyCorruptSource (in category 'misc') ----- - informPossiblyCorruptSource - - | sourcesName | - sourcesName := FileDirectory localNameFor: Smalltalk sourcesName. - self inform: ('There may be a problem with your sources file!! - - The source code for every method should (usually) start with the method selector but this is not the case with this method!! You may proceed with caution but it is recommended that you get a new source file. - - This can happen if you download the "{1}" file, or the ".changes" file you use, as TEXT. It must be transfered in BINARY mode, even if it looks like a text file, to preserve the CR line ends. - - Mac users: This may have been caused by Stuffit Expander. To prevent the files above to be converted to Mac line ends when they are expanded, do this: Start the program, then from Preferences... in the File menu, choose the Cross Platform panel, then select "Never" and press OK. Then expand the compressed archive again. - - (Occasionally, the source code for a method may legitimately start with a non-alphabetic character -- for example, Behavior - method #formalHeaderPartsFor:. In such rare cases, you can happily disregard this warning.)' translated format: {sourcesName})! Item was removed: - ----- Method: CodeHolder>>inheritanceButtonColor (in category 'toolbuilder') ----- - inheritanceButtonColor - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | flags aColor cm defaultButtonColor | - defaultButtonColor := (UserInterfaceTheme current get: #color for: #PluggableButtonMorph) ifNil: [Color gray: 0.91]. - cm := currentCompiledMethod. - ((cm isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons]) - ifFalse: [^ defaultButtonColor]. - - "This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it." - - flags := 0. - self isThisAnOverride ifTrue: [ flags := flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags := flags bitOr: 2 ]. - self isThereAnOverride ifTrue: [ flags := flags bitOr: 1 ]. - aColor := { - defaultButtonColor. - Color tan lighter. - Color green muchLighter. - Color blue muchLighter. - Color red muchLighter. "has super but doesn't call it" - (Color r: 0.94 g: 0.823 b: 0.673). "has sub; has super but doesn't call it" - Color green muchLighter. - Color blue muchLighter. - } at: flags + 1. - - ^aColor! Item was removed: - ----- Method: CodeHolder>>inheritanceButtonEnabled (in category 'toolbuilder') ----- - inheritanceButtonEnabled - "The inheritance button is only enabled when a method is selected" - - ^ self selectedMessageName notNil - ! Item was removed: - ----- Method: CodeHolder>>inspectMethod (in category 'message functions') ----- - inspectMethod - (self selectedClassOrMetaClass - compiledMethodAt: self selectedMessageName - ifAbsent: []) ifNotNil: - [:method| method inspect]! Item was removed: - ----- Method: CodeHolder>>installTextualCodingPane (in category 'diffs') ----- - installTextualCodingPane - "Install text into the code pane" - - | aWindow codePane aPane boundsToUse | - (aWindow := self containingWindow) ifNil: [self error: 'where''s that window?']. - codePane := self codeTextMorph ifNil: [self error: 'no code pane']. - aPane := self buildMorphicCodePaneWith: nil. - boundsToUse := (codePane bounds origin- (1 at 1)) corner: (codePane owner bounds corner " (1 at 1"). - aWindow replacePane: codePane with: aPane. - aPane vResizing: #spaceFill; hResizing: #spaceFill; borderWidth: 0. - aPane bounds: boundsToUse. - aPane owner clipSubmorphs: false. - - self contentsChanged! Item was removed: - ----- Method: CodeHolder>>isBreakOnEntry (in category 'breakpoints') ----- - isBreakOnEntry - - ^self selectedClassOrMetaClass - ifNil: [false] - ifNotNil: - [:class| - (class - compiledMethodAt: self selectedMessageName - ifAbsent: nil) - ifNil: [false] - ifNotNil: [:method| method hasBreakpoint]]! Item was removed: - ----- Method: CodeHolder>>isModeStyleable (in category 'contents') ----- - isModeStyleable - "determine the current mode can be styled" - ^ self showingSource or: [self showingPrettyPrint] or: [self showingDecompile]! Item was removed: - ----- Method: CodeHolder>>isThereAnOverride (in category 'misc') ----- - isThereAnOverride - "Answer whether any subclass of my selected class implements my selected selector" - - | aName aClass | - aName := self selectedMessageName ifNil: [^ false]. - aClass := self selectedClassOrMetaClass ifNil: [^ false]. - ^aClass isSelectorOverridden: aName! Item was removed: - ----- Method: CodeHolder>>isThisAnOverride (in category 'misc') ----- - isThisAnOverride - "Answer whether any superclass of my selected class implements my selected selector" - - | aName aClass | - aName := self selectedMessageName ifNil: [^ false]. - aClass := self selectedClassOrMetaClass ifNil: [^ false]. - ^aClass isSelectorOverride: aName! Item was removed: - ----- Method: CodeHolder>>labelString (in category 'initialize-release') ----- - labelString - - ^ currentCompiledMethod - ifNil: [self defaultBrowserTitle] - ifNotNil: [ - ('{1} {2} \{{3}\} \{{4}\}' format: { - self selectedClassOrMetaClass name. - self selectedMessageName. - self selectedMessageCategoryName. - self selectedSystemCategoryName })]! Item was removed: - ----- Method: CodeHolder>>letUserReclassify:in: (in category 'categories') ----- - letUserReclassify: anElement in: aClass - "Put up a list of categories and solicit one from the user. - Answer true if user indeed made a change, else false" - - - | currentCat newCat | - currentCat := aClass organization categoryOfElement: anElement. - newCat := self - categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")' - for: aClass. - (newCat ~~ nil and: [newCat ~= currentCat]) - ifTrue: - [aClass organization classify: anElement under: newCat suppressIfDefault: false logged: true. - ^ true] - ifFalse: - [^ false]! Item was removed: - ----- Method: CodeHolder>>listPaneWithSelector: (in category 'categories & search pane') ----- - listPaneWithSelector: aSelector - "If, among my window's paneMorphs, there is a list pane defined with aSelector as its retriever, answer it, else answer nil" - - | aWindow | - Smalltalk isMorphic ifFalse: [^ nil]. - ^ (aWindow := self containingWindow) ifNotNil: - [aWindow paneMorphSatisfying: - [:aMorph | (aMorph isKindOf: PluggableListMorph) and: - [aMorph getListSelector == aSelector]]]! Item was removed: - ----- Method: CodeHolder>>makeSampleInstance (in category 'traits') ----- - makeSampleInstance - | aClass nonMetaClass anInstance | - ((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait]) ifTrue: [^ self]. - nonMetaClass := aClass theNonMetaClass. - anInstance := self sampleInstanceOfSelectedClass. - (anInstance isNil and: [nonMetaClass ~~ UndefinedObject]) ifTrue: - [^ self inform: 'Sorry, cannot make an instance of ', nonMetaClass name]. - - (Smalltalk isMorphic and: [anInstance isMorph]) - ifTrue: - [self currentHand attachMorph: anInstance] - ifFalse: - [anInstance inspectWithLabel: 'An instance of ', nonMetaClass name]! Item was removed: - ----- Method: CodeHolder>>messageHelpForMethod: (in category 'message list') ----- - messageHelpForMethod: aMethod - "Answer the formatted help text for a method." - "Show the first n lines of the source code of the method." - | source formatted | - source := aMethod getSource. - formatted := (TextStyler for: #Smalltalk) - ifNil: [ source asText ] - ifNotNil: [ :textStylerClass | - textStylerClass new - classOrMetaClass: aMethod methodClass; - styledTextFor: source asText ]. - ^ self messageHelpTruncated: formatted! Item was removed: - ----- Method: CodeHolder>>messageHelpTruncated: (in category 'message list') ----- - messageHelpTruncated: aText - "Show only the first n lines of the text." - | formatted lineCount | - formatted := aText. - lineCount := 0. - aText withIndexDo: [:char :index | - char = Character cr ifTrue: [lineCount := lineCount + 1]. - lineCount > 10 ifTrue: [ - formatted := formatted copyFrom: 1 to: index-1. - formatted append: ' [...]'. - ^ formatted]]. - ^ formatted! Item was removed: - ----- Method: CodeHolder>>messageListKey:from: (in category 'message list menu') ----- - messageListKey: aChar from: view - "Overwritten to add more code-specific commands." - - aChar == $d ifTrue: [^ self removeMessageFromBrowser]. - - self selectedClassOrMetaClass ifNotNil: [ - aChar == $r ifTrue: [^ self browseVariableReferences]. - aChar == $a ifTrue: [^ self browseVariableAssignments]. - (aChar == $Y and: [self canShowMultipleMessageCategories]) - ifTrue: [^ self showHomeCategory]]. - - ^ super messageListKey: aChar from: view! Item was removed: - ----- Method: CodeHolder>>messageListMenuMore: (in category 'message list menu') ----- - messageListMenuMore: aMenu - " The 'more..' link that toggles between shifted and unshifted menus - in message lists and context stacks " - <messageListMenuShifted: false> - <contextStackMenuShifted: false> - <menuPriority: 1000> - ^ aMenu addList: #( - - - ('more...' shiftedYellowButtonActivity)); - yourself - ! Item was removed: - ----- Method: CodeHolder>>metaClassIndicated (in category 'accessing') ----- - metaClassIndicated - - ^ self selectedClassOrMetaClass isMeta! Item was removed: - ----- Method: CodeHolder>>methodCategoryChanged (in category 'categories') ----- - methodCategoryChanged - self changed: #annotation! Item was removed: - ----- Method: CodeHolder>>modelWakeUpIn: (in category 'misc') ----- - modelWakeUpIn: aWindow - "The window has been activated. Respond to possible changes that may have taken place while it was inactive" - - self updateListsAndCodeIn: aWindow. - self decorateButtons. - self refreshAnnotation. - - super modelWakeUpIn: aWindow! Item was removed: - ----- Method: CodeHolder>>multiWindowState (in category 'multi-window support') ----- - multiWindowState - ^multiWindowState! Item was removed: - ----- Method: CodeHolder>>multiWindowState: (in category 'multi-window support') ----- - multiWindowState: aSavedMultiWindowState - multiWindowState := aSavedMultiWindowState! Item was removed: - ----- Method: CodeHolder>>newSearchPane (in category 'categories & search pane') ----- - newSearchPane - "Answer a new search pane for the receiver" - - | aTextMorph | - aTextMorph := PluggableTextMorph on: self - text: #lastSearchString accept: #lastSearchString: - readSelection: nil menu: nil. - aTextMorph setProperty: #alwaysAccept toValue: true. - aTextMorph askBeforeDiscardingEdits: false. - aTextMorph acceptOnCR: true. - aTextMorph setBalloonText: 'Type here and hit ENTER, and all methods whose selectors match what you typed will appear in the list pane below.'. - ^ aTextMorph! Item was removed: - ----- Method: CodeHolder>>offerMenu (in category 'commands') ----- - offerMenu - "Offer a menu to the user from the bar of tool buttons" - - self offerDurableMenuFrom: #messageListMenu:shifted: shifted: false! Item was removed: - ----- Method: CodeHolder>>offerShiftedClassListMenu (in category 'commands') ----- - offerShiftedClassListMenu - "Offer the shifted class-list menu." - - ^ self offerMenuFrom: #classListMenu:shifted: shifted: true! Item was removed: - ----- Method: CodeHolder>>offerUnshiftedClassListMenu (in category 'commands') ----- - offerUnshiftedClassListMenu - "Offer the shifted class-list menu." - - ^ self offerMenuFrom: #classListMenu:shifted: shifted: false! Item was removed: - ----- Method: CodeHolder>>offerWhatToShowMenu (in category 'what to show') ----- - offerWhatToShowMenu - "Offer a menu governing what to show" - | builder menuSpec | - builder := ToolBuilder default. - menuSpec := builder pluggableMenuSpec new. - self contentsSymbolQuints do: [:aQuint | aQuint == #- - ifTrue: [menuSpec addSeparator] - ifFalse: [ - | item | - item := menuSpec add: (self perform: aQuint third) - target: self selector: aQuint second argumentList: #(). - item help: aQuint fifth. - ]. - ]. - builder runModal: (builder open: menuSpec).! Item was removed: - ----- Method: CodeHolder>>okayToAccept (in category 'misc') ----- - okayToAccept - "Answer whether it is okay to accept the receiver's input" - - self showingDocumentation ifTrue: - [self inform: - 'Sorry, for the moment you can - only submit changes here when - you are showing source. Later, you - will be able to edit the isolated comment - here and save it back, but only if YOU - implement it!!.'. - ^ false]. - - self showingEditContentsOption ifTrue: - [self inform: 'Cannot accept ', self contentsSymbol, ' input'. - ^ false]. - - self showingAnyKindOfDiffs ifFalse: - [^ true]. - ^ (Project uiManager - chooseOptionFrom: - {'accept anyway -- I''ll take my chances'. - 'um, let me reconsider'.} - title: - 'Caution!! You are "showing diffs" here, so - there is a danger that some of the text in the - code pane is contaminated by the "diff" display') = 1! Item was removed: - ----- Method: CodeHolder>>optionalButtonPairs (in category 'controls') ----- - optionalButtonPairs - "Answer a tuple (formerly pairs) defining buttons, in the format: - button label - selector to send - help message" - - | aList | - - aList := #( - ('browse' browseMethodFull 'view this method in a browser') - ('senders' browseSendersOfMessages 'browse senders of...') - ('implementors' browseMessages 'browse implementors of...') - ('versions' browseVersions 'browse versions')), - - (Preferences decorateBrowserButtons - ifTrue: - [{#('inheritance' methodHierarchy 'browse method inheritance - green: sends to super - tan: has override(s) - mauve: both of the above - pink: is an override but doesn''t call super - pinkish tan: has override(s), also is an override but doesn''t call super' )}] - ifFalse: - [{#('inheritance' methodHierarchy 'browse method inheritance')}]), - - #( - ('hierarchy' browseClassHierarchy 'browse class hierarchy') - ('variables' browseVariableReferences 'browse references to variables...')). - - ^ aList! Item was removed: - ----- Method: CodeHolder>>optionalButtonsFrame (in category 'toolbuilder') ----- - optionalButtonsFrame - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self buttonHeight! Item was removed: - ----- Method: CodeHolder>>prettyPrintString (in category 'what to show') ----- - prettyPrintString - "Answer whether the receiver is showing pretty-print" - - ^ ((contentsSymbol == #prettyPrint) - ifTrue: - ['<yes>'] - ifFalse: - ['<no>']), 'prettyPrint'! Item was removed: - ----- Method: CodeHolder>>priorSourceOrNil (in category 'misc') ----- - priorSourceOrNil - "If the currently-selected method has a previous version, return its source, else return nil" - | aClass aSelector changeRecords | - (aClass := self selectedClassOrMetaClass) ifNil: [^ nil]. - (aSelector := self selectedMessageName) ifNil: [^ nil]. - changeRecords := aClass changeRecordsAt: aSelector. - (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. - ^ (changeRecords at: 2) string - ! Item was removed: - ----- Method: CodeHolder>>receiverClass (in category 'toolbuilder') ----- - receiverClass - ^ self selectedClassOrMetaClass ! Item was removed: - ----- Method: CodeHolder>>refreshAnnotation (in category 'misc') ----- - refreshAnnotation - "If the receiver has an annotation pane that does not bear unaccepted edits, refresh it" - - (self dependents detect: [:m | (m inheritsFromAnyIn: #('PluggableTextView' 'PluggableTextMorph')) and: [m getTextSelector == #annotation]] ifNone: [nil]) ifNotNil: - [:aPane | aPane hasUnacceptedEdits ifFalse: - [aPane update: #annotation]]! Item was removed: - ----- Method: CodeHolder>>refusesToAcceptCode (in category 'misc') ----- - refusesToAcceptCode - "Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to" - - ^ (#(byteCodes documentation tiles) includes: self contentsSymbol)! Item was removed: - ----- Method: CodeHolder>>releaseCachedState (in category 'misc') ----- - releaseCachedState - "Can always be found again. Don't write on a file." - currentCompiledMethod := nil.! Item was removed: - ----- Method: CodeHolder>>removeClass (in category 'class functions') ----- - removeClass - "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." - - self okToChange ifFalse: [^ false]. - ^ self systemNavigation confirmAndRemoveClass: self selectedClass! Item was removed: - ----- Method: CodeHolder>>removeMessage (in category 'message functions') ----- - removeMessage - "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. Answer a boolean indicating whether the removal was succesful." - - self okToChange ifFalse: [^ false]. - ^ self systemNavigation - confirmAndRemoveSelector: self selectedMessageName - class: self selectedClassOrMetaClass! Item was removed: - ----- Method: CodeHolder>>removeMessageCategory (in category 'message category functions') ----- - removeMessageCategory - "If a message category is selected, create a Confirmer so the user can verify that the currently selected message category should be removed from the system. If so, remove it." - - self okToChange ifFalse: [^ false]. - ^ self systemNavigation - confirmAndRemoveMessageCategory: self selectedMessageCategoryName - class: self selectedClassOrMetaClass! Item was removed: - ----- Method: CodeHolder>>removeSystemCategory (in category 'system category functions') ----- - removeSystemCategory - "If a class category is selected, create a Confirmer so the user can verify that the currently selected class category and all of its classes should be removed from the system. If so, remove it." - - self okToChange ifFalse: [^ false]. - ^ self systemNavigation confirmAndRemoveSystemCategory: self selectedSystemCategoryName! Item was removed: - ----- Method: CodeHolder>>restoreTextualCodingPane (in category 'diffs') ----- - restoreTextualCodingPane - "If the receiver is showing tiles, restore the textual coding pane" - - contentsSymbol == #tiles ifTrue: - [contentsSymbol := #source. - self installTextualCodingPane]! Item was removed: - ----- Method: CodeHolder>>sampleInstanceOfSelectedClass (in category 'misc') ----- - sampleInstanceOfSelectedClass - | aClass | - "Return a sample instance of the class currently being pointed at" - (aClass := self selectedClassOrMetaClass) ifNil: [^ nil]. - ^ aClass theNonMetaClass initializedInstance! Item was removed: - ----- Method: CodeHolder>>searchTextMorph (in category 'categories & search pane') ----- - searchTextMorph - "Answer the search pane associated with the receiver in its window, or nil if none. Morphic only" - - | pane | - pane := self anyTextPaneWithSelector: #lastSearchString. - ^ pane isMorph ifTrue: [pane]! Item was removed: - ----- Method: CodeHolder>>selectedBytecodes (in category 'message list') ----- - selectedBytecodes - "Answer text to show in a code pane when in showing-byte-codes mode" - - ^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText! Item was removed: - ----- Method: CodeHolder>>selectedClass (in category 'accessing') ----- - selectedClass - - ^ self selectedClassOrMetaClass ifNotNil: [:cls | cls theNonMetaClass]! Item was removed: - ----- Method: CodeHolder>>selectedClassOrMetaClass (in category 'accessing') ----- - selectedClassOrMetaClass - - ^ currentCompiledMethod ifNotNil: [:method | method methodClass]! Item was removed: - ----- Method: CodeHolder>>selectedMessage (in category 'message list') ----- - selectedMessage - "Answer a copy of the source code for the selected message. This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super. In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here. Everything in good time." - - | class selector method | - contents ifNotNil: [^ contents copy]. - - self showingDecompile ifTrue:[^ self decompiledSourceIntoContents]. - - class := self selectedClassOrMetaClass. - (class isNil or: [(selector := self selectedMessageName) isNil]) ifTrue: [^ '']. - method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" - currentCompiledMethod := method. - - ^ contents := (self showingDocumentation - ifFalse: [self sourceStringPrettifiedAndDiffed] - ifTrue: [ self commentContents]) - copy asText makeSelectorBoldIn: class! Item was removed: - ----- Method: CodeHolder>>selectedMessageCategoryName (in category 'categories') ----- - selectedMessageCategoryName - "Answer the name of the message category of the message of the currently selected context." - - ^ self selectedClassOrMetaClass organization categoryOfElement: self selectedMessageName! Item was removed: - ----- Method: CodeHolder>>selectedMessageName (in category 'accessing') ----- - selectedMessageName - - ^ currentCompiledMethod - ifNil: [super selectedMessageName] - ifNotNil: [:method | method selector]! Item was removed: - ----- Method: CodeHolder>>selectedSystemCategoryName (in category 'categories') ----- - selectedSystemCategoryName - - ^ self systemOrganizer categoryOfElement: self selectedClass name! Item was removed: - ----- Method: CodeHolder>>sendQuery:to: (in category 'misc') ----- - sendQuery: querySelector to: queryPerformer - "See commentary in #sendQuery:to:with:." - - ^ self sendQuery: querySelector to: queryPerformer with: { }! Item was removed: - ----- Method: CodeHolder>>sendQuery:to:with: (in category 'misc') ----- - sendQuery: querySelector to: queryPerformer with: queryArgs - "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument. Unlike #getSelectorAndSendQuery:to:with:, DO NOT let the user choose from the list of known symbols inside the selected context/message." - - ^ self selectedMessageName - ifNotNil: [ :aSymbol | "We have a message name. Use it directly." - queryPerformer - perform: querySelector - withArguments: {aSymbol}, queryArgs ] - ifNil: [ "No message currently selected. Obtain a selector from a user type-in." - (Project uiManager request: 'Type selector:' initialAnswer: 'flag:') - ifEmpty: [ nil "Cancelled by user" ] - ifNotEmpty: [ :typeIn | | selectorString | - (Symbol lookup: (selectorString := typeIn asLegalSelector)) - ifNil: [ self inform: 'There is no symbol known as #', selectorString ] - ifNotNil: [ :aSymbol | - queryPerformer - perform: querySelector - withArguments: {aSymbol}, queryArgs ] ]]! Item was removed: - ----- Method: CodeHolder>>setClass:selector: (in category 'initialize-release') ----- - setClass: aBehavior selector: aSymbol - - contents := nil. - currentCompiledMethod := aBehavior compiledMethodAt: aSymbol. - self changed: #relabel. - self contentsChanged. - self decorateButtons.! Item was removed: - ----- Method: CodeHolder>>setClassAndSelectorIn: (in category 'misc') ----- - setClassAndSelectorIn: csBlock - "Evaluate csBlock with my selected class and and selector as its arguments; provide nil arguments if I don't have a method currently selected" - - | aName | - (aName := self selectedMessageName) - ifNil: - [csBlock value: nil value: nil] - ifNotNil: - [csBlock value: self selectedClassOrMetaClass value: aName] - ! Item was removed: - ----- Method: CodeHolder>>setContentsToForceRefetch (in category 'what to show') ----- - setContentsToForceRefetch - "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" - - contents := nil! Item was removed: - ----- Method: CodeHolder>>shiftedMessageListMore: (in category 'message list menu') ----- - shiftedMessageListMore: aMenu - " The 'more..' link that toggles between shifted and unshifted menus - in message lists and context stacks " - <messageListMenuShifted: true> - <contextStackMenuShifted: true> - <menuPriority: 1000> - ^ aMenu addList: #( - - - ('more...' unshiftedYellowButtonActivity)); - yourself - ! Item was removed: - ----- Method: CodeHolder>>shiftedYellowButtonActivity (in category 'commands') ----- - shiftedYellowButtonActivity - "Offer the shifted selector-list menu" - - ^ self offerMenuFrom: #messageListMenu:shifted: shifted: true! Item was removed: - ----- Method: CodeHolder>>showByteCodes: (in category 'what to show') ----- - showByteCodes: aBoolean - "Get into or out of bytecode-showoing mode" - - self okToChange ifFalse: [^ self changed: #flash]. - aBoolean - ifTrue: - [contentsSymbol := #byteCodes] - ifFalse: - [contentsSymbol == #byteCodes ifTrue: [contentsSymbol := #source]]. - self contentsChanged! Item was removed: - ----- Method: CodeHolder>>showDecompile: (in category 'what to show') ----- - showDecompile: aBoolean - "Set the decompile toggle as indicated" - - self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])! Item was removed: - ----- Method: CodeHolder>>showDiffs (in category 'diffs') ----- - showDiffs - "Answer whether the receiver is showing diffs of source code. The preferred protocol here is #showingRegularDiffs, but this message is still sent by some preexisting buttons so is retained." - - ^ contentsSymbol == #showDiffs - ! Item was removed: - ----- Method: CodeHolder>>showDiffs: (in category 'diffs') ----- - showDiffs: aBoolean - "Set whether I'm showing diffs as indicated; use the global preference to determine which kind of diffs to institute." - - self showingAnyKindOfDiffs - ifFalse: - [aBoolean ifTrue: - [contentsSymbol := self defaultDiffsSymbol]] - ifTrue: - [aBoolean ifFalse: - [contentsSymbol := #source]]. - self setContentsToForceRefetch. - self contentsChanged! Item was removed: - ----- Method: CodeHolder>>showDocumentation: (in category 'what to show') ----- - showDocumentation: aBoolean - "Set the showDocumentation toggle as indicated" - - self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#documentation])! Item was removed: - ----- Method: CodeHolder>>showPrettyDiffs: (in category 'diffs') ----- - showPrettyDiffs: aBoolean - "Set whether I'm showing pretty diffs as indicated" - - self showingPrettyDiffs - ifFalse: - [aBoolean ifTrue: - [contentsSymbol := #prettyDiffs]] - ifTrue: - [aBoolean ifFalse: - [contentsSymbol := #source]]. - self setContentsToForceRefetch. - self contentsChanged! Item was removed: - ----- Method: CodeHolder>>showRegularDiffs: (in category 'diffs') ----- - showRegularDiffs: aBoolean - "Set whether I'm showing regular diffs as indicated" - - self showingRegularDiffs - ifFalse: - [aBoolean ifTrue: - [contentsSymbol := #showDiffs]] - ifTrue: - [aBoolean ifFalse: - [contentsSymbol := #source]]. - self setContentsToForceRefetch. - self contentsChanged! Item was removed: - ----- Method: CodeHolder>>showUnreferencedClassVars (in category 'traits') ----- - showUnreferencedClassVars - "Search for all class variables known to the selected class, and put up a - list of those that have no references anywhere in the system. The - search includes superclasses, so that you don't need to navigate your - way to the class that defines each class variable in order to determine - whether it is unreferenced" - | cls aList aReport | - ((cls := self selectedClass) isNil or: [cls isTrait]) ifTrue: [^ self]. - aList := self systemNavigation allUnreferencedClassVariablesOf: cls. - aList size = 0 - ifTrue: [^ self inform: 'There are no unreferenced - class variables in - ' , cls name]. - aReport := String - streamContents: [:aStream | - aStream nextPutAll: 'Unreferenced class variable(s) in ' , cls name; - cr. - aList - do: [:el | aStream tab; nextPutAll: el; cr]]. - Transcript cr; show: aReport. - UIManager default chooseFrom: aList values: aList - title: 'Unreferenced - class variables in - ' , cls name! Item was removed: - ----- Method: CodeHolder>>showUnreferencedInstVars (in category 'traits') ----- - showUnreferencedInstVars - "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" - - | cls aList aReport | - ((cls := self selectedClassOrMetaClass) isNil or: [cls isTrait]) ifTrue: [^ self]. - aList := cls allUnreferencedInstanceVariables. - aList size = 0 ifTrue: [^ self inform: 'There are no unreferenced - instance variables in - ', cls name]. - aReport := String streamContents: - [:aStream | - aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr. - aList do: [:el | aStream tab; nextPutAll: el; cr]]. - Transcript cr; show: aReport. - UIManager default chooseFrom: aList values: aList title: 'Unreferenced - instance variables in - ', cls name! Item was removed: - ----- Method: CodeHolder>>showingAnyKindOfDiffs (in category 'diffs') ----- - showingAnyKindOfDiffs - "Answer whether the receiver is currently set to show any kind of diffs" - - ^ #(showDiffs prettyDiffs) includes: contentsSymbol! Item was removed: - ----- Method: CodeHolder>>showingByteCodes (in category 'what to show') ----- - showingByteCodes - "Answer whether the receiver is showing bytecodes" - - ^ contentsSymbol == #byteCodes! Item was removed: - ----- Method: CodeHolder>>showingByteCodesString (in category 'what to show') ----- - showingByteCodesString - "Answer whether the receiver is showing bytecodes" - - ^ (self showingByteCodes - ifTrue: - ['<yes>'] - ifFalse: - ['<no>']), 'byteCodes'! Item was removed: - ----- Method: CodeHolder>>showingDecompile (in category 'what to show') ----- - showingDecompile - "Answer whether the receiver should show decompile rather than, say, source code" - - ^ self contentsSymbol == #decompile - ! Item was removed: - ----- Method: CodeHolder>>showingDecompileString (in category 'what to show') ----- - showingDecompileString - "Answer a string characerizing whether decompilation is showing" - - ^ (self showingDecompile - ifTrue: - ['<yes>'] - ifFalse: - ['<no>']), 'decompile'! Item was removed: - ----- Method: CodeHolder>>showingDocumentation (in category 'what to show') ----- - showingDocumentation - "Answer whether the receiver should show documentation rather than, say, source code" - - ^ self contentsSymbol == #documentation - ! Item was removed: - ----- Method: CodeHolder>>showingDocumentationString (in category 'what to show') ----- - showingDocumentationString - "Answer a string characerizing whether documentation is showing" - - ^ (self showingDocumentation - ifTrue: - ['<yes>'] - ifFalse: - ['<no>']), 'documentation'! Item was removed: - ----- Method: CodeHolder>>showingEditContentsOption (in category 'what to show') ----- - showingEditContentsOption - "True if any of the optional EditContentsOptions modes is in effect. This - includes bytecode display and possibly other display modes." - - ^ EditContentsOptions includesKey: self contentsSymbol - ! Item was removed: - ----- Method: CodeHolder>>showingPlainSource (in category 'what to show') ----- - showingPlainSource - "Answer whether the receiver is showing plain source" - - ^ contentsSymbol == #source! Item was removed: - ----- Method: CodeHolder>>showingPlainSourceString (in category 'what to show') ----- - showingPlainSourceString - "Answer a string telling whether the receiver is showing plain source" - - ^ (self showingPlainSource - ifTrue: - ['<yes>'] - ifFalse: - ['<no>']), 'source'! Item was removed: - ----- Method: CodeHolder>>showingPrettyDiffs (in category 'diffs') ----- - showingPrettyDiffs - "Answer whether the receiver is showing pretty diffs of source code" - - ^ contentsSymbol == #prettyDiffs - ! Item was removed: - ----- Method: CodeHolder>>showingPrettyDiffsString (in category 'diffs') ----- - showingPrettyDiffsString - "Answer a string representing whether I'm showing pretty diffs" - - ^ (self showingPrettyDiffs - ifTrue: - ['<yes>'] - ifFalse: - ['<no>']), 'prettyDiffs'! Item was removed: - ----- Method: CodeHolder>>showingPrettyPrint (in category 'what to show') ----- - showingPrettyPrint - "Answer whether the receiver is showing pretty-print" - - ^ contentsSymbol == #prettyPrint! Item was removed: - ----- Method: CodeHolder>>showingRegularDiffs (in category 'diffs') ----- - showingRegularDiffs - "Answer whether the receiver is showing regular diffs of source code" - - ^ contentsSymbol == #showDiffs - ! Item was removed: - ----- Method: CodeHolder>>showingRegularDiffsString (in category 'diffs') ----- - showingRegularDiffsString - "Answer a string representing whether I'm showing regular diffs" - - ^ (self showingRegularDiffs - ifTrue: - ['<yes>'] - ifFalse: - ['<no>']), 'showDiffs'! Item was removed: - ----- Method: CodeHolder>>showingSource (in category 'what to show') ----- - showingSource - "Answer whether the receiver is currently showing source code" - - ^ self contentsSymbol == #source - ! Item was removed: - ----- Method: CodeHolder>>sourceAndDiffsQuintsOnly (in category 'controls') ----- - sourceAndDiffsQuintsOnly - "Answer a list of quintuplets representing information on the alternative views available in the code pane for the case where the only plausible choices are showing source or either of the two kinds of diffs" - - ^ #( - (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') - (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version') - (prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version'))! Item was removed: - ----- Method: CodeHolder>>sourceStringPrettifiedAndDiffed (in category 'message list') ----- - sourceStringPrettifiedAndDiffed - "Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies" - - | class selector sourceString | - class := self selectedClassOrMetaClass. - selector := self selectedMessageName. - (class isNil or: [selector isNil]) ifTrue: [^'missing']. - sourceString := class ultimateSourceCodeAt: selector ifAbsent: [^'error']. - self validateMessageSource: sourceString forSelector: selector inClass: class. - (#(#prettyPrint #prettyDiffs) - includes: contentsSymbol) - ifTrue: - [sourceString := class prettyPrinterClass - format: sourceString - in: class - notifying: nil]. - self showingAnyKindOfDiffs - ifTrue: [sourceString := self diffFromPriorSourceFor: sourceString]. - ^sourceString! Item was removed: - ----- Method: CodeHolder>>spawn: (in category 'commands') ----- - spawn: aString - "Create and schedule a spawned message category browser for the currently selected message category. The initial text view contains the characters in aString. In the spawned browser, preselect the current selector (if any) as the going-in assumption, though upon acceptance this will often change" - - self selectedClassOrMetaClass - ifNil: [ - ^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']] - ifNotNil: [:cls | - self categoryOfCurrentMethod - ifNil: [ - self buildClassBrowserEditString: aString] - ifNotNil: [:category | - self - buildMessageCategoryBrowserForCategory: category - class: cls - selector: self selectedMessageName - editString: aString]]! Item was removed: - ----- Method: CodeHolder>>spawnHierarchy (in category 'traits') ----- - spawnHierarchy - "Create and schedule a new hierarchy browser on the currently selected class or meta." - - ^ ToolSet - browseHierarchy: self selectedClassOrMetaClass - selector: self selectedMessageName! Item was removed: - ----- Method: CodeHolder>>spawnToClass: (in category 'commands') ----- - spawnToClass: aClass - "Used to copy down code from a superclass to a subclass in one easy step, if you know what you're doing. Spawns a new message-category browser for the indicated class, populating it with the source code seen in the current tool." - - self categoryOfCurrentMethod - ifNil: [ - self buildClassBrowserEditString: self contents] - ifNotNil: [:category | - self - buildMessageCategoryBrowserForCategory: category - class: aClass - selector: nil - editString: self contents]! Item was removed: - ----- Method: CodeHolder>>spawnToCollidingClass: (in category 'commands') ----- - spawnToCollidingClass: aClass - "Potentially used to copy down code from a superclass to a subclass in one easy step, in the case where the given class already has its own version of code, which would consequently be clobbered if the spawned code were accepted." - - self inform: 'That would be destructive of - some pre-existing code already in that - class for this selector. For the moment, - we will not let you do this to yourself.'! Item was removed: - ----- Method: CodeHolder>>stepIn: (in category 'self-updating') ----- - stepIn: aSystemWindow - self updateListsAndCodeIn: aSystemWindow! Item was removed: - ----- Method: CodeHolder>>suggestCategoryToSpawnedBrowser: (in category 'misc') ----- - suggestCategoryToSpawnedBrowser: aBrowser - "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." - - aBrowser setOriginalCategoryIndexForCurrentMethod! Item was removed: - ----- Method: CodeHolder>>systemOrganizer (in category 'accessing') ----- - systemOrganizer - - ^ SystemOrganization! Item was removed: - ----- Method: CodeHolder>>textFrame (in category 'toolbuilder') ----- - textFrame - | topOffset bottomOffset | - topOffset := self wantsOptionalButtons - ifTrue: [self buttonHeight] - ifFalse: [0]. - bottomOffset := self wantsAnnotationPane - ifTrue: [self annotationPaneHeight negated] - ifFalse: [0]. - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: topOffset; - rightFraction: 1 offset: 0; - bottomFraction: 1 offset: bottomOffset! Item was removed: - ----- Method: CodeHolder>>toggleBreakOnEntry (in category 'breakpoints') ----- - toggleBreakOnEntry - "Install or uninstall a halt-on-entry breakpoint" - - | selectedMethod | - self selectedClassOrMetaClass ifNil: [ ^self]. - selectedMethod := self selectedClassOrMetaClass - compiledMethodAt: self selectedMessageName - ifAbsent: [^ self]. - selectedMethod hasBreakpoint - ifTrue: - [BreakpointManager unInstall: selectedMethod] - ifFalse: - [BreakpointManager - installInClass: self selectedClassOrMetaClass - selector: self selectedMessageName]. - self changed: #messageList! Item was removed: - ----- Method: CodeHolder>>toggleDecompile (in category 'what to show') ----- - toggleDecompile - "Toggle the setting of the showingDecompile flag, unless there are unsubmitted edits that the user declines to discard" - - | wasShowing | - self okToChange ifTrue: - [wasShowing := self showingDecompile. - self restoreTextualCodingPane. - self showDecompile: wasShowing not. - self setContentsToForceRefetch. - self contentsChanged] - - ! Item was removed: - ----- Method: CodeHolder>>toggleDiffing (in category 'diffs') ----- - toggleDiffing - "Toggle whether diffs should be shown in the code pane. If any kind of diffs were being shown, stop showing diffs. If no kind of diffs were being shown, start showing whatever kind of diffs are called for by default." - - | wasShowingDiffs | - self okToChange ifTrue: - [wasShowingDiffs := self showingAnyKindOfDiffs. - self restoreTextualCodingPane. - self showDiffs: wasShowingDiffs not. - self setContentsToForceRefetch. - self contentsChanged] - - ! Item was removed: - ----- Method: CodeHolder>>togglePlainSource (in category 'diffs') ----- - togglePlainSource - "Toggle whether plain source shown in the code pane" - - | wasShowingPlainSource | - self okToChange ifTrue: - [wasShowingPlainSource := self showingPlainSource. - self restoreTextualCodingPane. - wasShowingPlainSource - ifTrue: - [self showDocumentation: true] - ifFalse: - [contentsSymbol := #source]. - self setContentsToForceRefetch. - self changed: #contents] - - ! Item was removed: - ----- Method: CodeHolder>>togglePrettyDiffing (in category 'diffs') ----- - togglePrettyDiffing - "Toggle whether pretty-diffing should be shown in the code pane" - - | wasShowingDiffs | - self okToChange ifTrue: - [wasShowingDiffs := self showingPrettyDiffs. - self restoreTextualCodingPane. - self showPrettyDiffs: wasShowingDiffs not. - self setContentsToForceRefetch. - self contentsChanged] - - ! Item was removed: - ----- Method: CodeHolder>>togglePrettyPrint (in category 'diffs') ----- - togglePrettyPrint - "Toggle whether pretty-print is in effectin the code pane" - - self restoreTextualCodingPane. - self okToChange ifTrue: - [self showingPrettyPrint - ifTrue: - [contentsSymbol := #source] - ifFalse: - [contentsSymbol := #prettyPrint]. - self setContentsToForceRefetch. - self contentsChanged] - - ! Item was removed: - ----- Method: CodeHolder>>toggleRegularDiffing (in category 'diffs') ----- - toggleRegularDiffing - "Toggle whether regular-diffing should be shown in the code pane" - - | wasShowingDiffs | - self okToChange ifTrue: - [wasShowingDiffs := self showingRegularDiffs. - self restoreTextualCodingPane. - self showRegularDiffs: wasShowingDiffs not. - self setContentsToForceRefetch. - self contentsChanged] - - ! Item was removed: - ----- Method: CodeHolder>>toggleShowDocumentation (in category 'what to show') ----- - toggleShowDocumentation - "Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard" - - | wasShowing | - self okToChange ifTrue: - [wasShowing := self showingDocumentation. - self restoreTextualCodingPane. - self showDocumentation: wasShowing not. - self setContentsToForceRefetch. - self contentsChanged] - - ! Item was removed: - ----- Method: CodeHolder>>toggleShowingByteCodes (in category 'what to show') ----- - toggleShowingByteCodes - "Toggle whether the receiver is showing bytecodes" - - self restoreTextualCodingPane. - self showByteCodes: self showingByteCodes not. - self setContentsToForceRefetch. - self contentsChanged! Item was removed: - ----- Method: CodeHolder>>unshiftedYellowButtonActivity (in category 'commands') ----- - unshiftedYellowButtonActivity - "Offer the unshifted shifted selector-list menu" - - ^ self offerMenuFrom: #messageListMenu:shifted: shifted: false! Item was removed: - ----- Method: CodeHolder>>updateCodePaneIfNeeded (in category 'self-updating') ----- - updateCodePaneIfNeeded - "If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits" - - self didCodeChangeElsewhere - ifTrue: - [self hasUnacceptedEdits - ifFalse: - [self setContentsToForceRefetch. - self contentsChanged] - ifTrue: - [self changed: #codeChangedElsewhere]]! Item was removed: - ----- Method: CodeHolder>>updateListsAndCodeIn: (in category 'self-updating') ----- - updateListsAndCodeIn: aWindow - super updateListsAndCodeIn: aWindow. - self updateCodePaneIfNeeded! Item was removed: - ----- Method: CodeHolder>>useSelector:orGetSelectorAndSendQuery:to: (in category 'misc') ----- - useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer - - self flag: #deprecated. - self selectedMessageName = incomingSelector - ifFalse: [^ self notify: 'This protocol is not supported anymore. Please revise using #seletedMessageName and either #sendQuery:to:with: or #getSelectorAndSendQuery:to:with:.']. - - ^ self sendQuery: querySelector to: queryPerformer! Item was removed: - ----- Method: CodeHolder>>validateMessageSource:forSelector:inClass: (in category 'message list') ----- - validateMessageSource: sourceString forSelector: aSelector inClass: theClass - "Check whether there is evidence that method source is invalid" - - (theClass newParser parseSelector: sourceString asString) = aSelector - ifFalse: [self informPossiblyCorruptSource].! Item was removed: - ----- Method: CodeHolder>>versionsButtonEnabled (in category 'toolbuilder') ----- - versionsButtonEnabled - "The versions button is only enabled when a method is selected or we view the - class comment." - - ^ self selectedMessageName notNil or: [self classCommentIndicated]! Item was removed: - ----- Method: CodeHolder>>wantsCodeProvenanceButton (in category 'what to show') ----- - wantsCodeProvenanceButton - - ^ true! Item was removed: - ----- Method: CodeHolder>>wantsDiffFeedback (in category 'diffs') ----- - wantsDiffFeedback - "Answer whether the receiver is showing diffs of source code" - - ^ self showingAnyKindOfDiffs! Item was removed: - ----- Method: CodeHolder>>wantsStepsIn: (in category 'self-updating') ----- - wantsStepsIn: aWindow - ^ Preferences smartUpdating! Item was removed: - ----- Method: Collection class>>toolIcon (in category '*Tools-icons') ----- - toolIcon - - ^ #collection! Item was removed: - ----- Method: Collection>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Collection'! Item was removed: - ----- Method: Collection>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ CollectionInspector! Item was removed: - Inspector subclass: #CollectionInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !CollectionInspector commentStamp: 'mt 3/31/2020 10:18' prior: 0! - I am an Inspector that is specialized for inspecting collections. I provide extended access to the inspected collection's items, such as adding and removing items. - - Note that I can directly inspect instances of ArrayedCollection and alike.! Item was removed: - ----- Method: CollectionInspector>>addCollectionItemsTo: (in category 'menu - construction') ----- - addCollectionItemsTo: aMenu - - aMenu addLine. - super addCollectionItemsTo: aMenu. - - self object isReadOnlyObject ifTrue: [^ self]. - aMenu addTranslatedList: #( - ('refresh list view' updateFields) "--- useful in non-stepping debugger"). - - self canAddOrRemoveElements ifFalse: [^ self]. - aMenu addTranslatedList: #( - - - ('add element...' addElement)). - - self typeOfSelection = #element ifFalse: [^ self]. - aMenu addTranslatedList: #( - ('remove element (x)' removeSelection)).! Item was removed: - ----- Method: CollectionInspector>>addElement (in category 'menu - commands') ----- - addElement - - self addElement: ( - self - requestObject: 'Enter expression for new object' translated - orCancel: [^ self]).! Item was removed: - ----- Method: CollectionInspector>>addElement: (in category 'menu - commands') ----- - addElement: anObject - - self object add: anObject. - - self updateFields. - self selectFieldSuchThat: [:field | [(field getValueFor: self) == anObject] ifError: [false]]. - self hasSelection ifFalse: [self inform: ('The new element {1} was added.\\Yet, the list of fields is quite long. The new field\got truncated and is thus not visible.' translated withCRs format: {anObject printString})].! Item was removed: - ----- Method: CollectionInspector>>assertElementSelectedOr: (in category 'private') ----- - assertElementSelectedOr: aBlock - - ^ self typeOfSelection = #element - or: [aBlock cull: self selectedField]! Item was removed: - ----- Method: CollectionInspector>>canAddOrRemoveElements (in category 'private') ----- - canAddOrRemoveElements - "For simplicity, treat those properties together. There are no collections that support addition but deny removal of elements." - - ^ #(add: remove:ifAbsent:) noneSatisfy: [:selector | - (self object class lookupSelector: selector) hasLiteral: #shouldNotImplement]! Item was removed: - ----- Method: CollectionInspector>>elementGetterAt: (in category 'private') ----- - elementGetterAt: index - - ^ [:collection | collection at: index] ! Item was removed: - ----- Method: CollectionInspector>>elementIndices (in category 'private') ----- - elementIndices - - ^ 1 to: self objectSize! Item was removed: - ----- Method: CollectionInspector>>elementNameAt: (in category 'private') ----- - elementNameAt: index - - ^ index printString! Item was removed: - ----- Method: CollectionInspector>>elementSetterAt: (in category 'private') ----- - elementSetterAt: index - - ^ [:collection :element | collection at: index put: element] ! Item was removed: - ----- Method: CollectionInspector>>inspectOne (in category 'menu - commands') ----- - inspectOne - "Only list the collection's elements. Ignore any other fields." - - self inspectOneOf: self elementIndices.! Item was removed: - ----- Method: CollectionInspector>>inspectorKey:from: (in category 'menu') ----- - inspectorKey: aChar from: view - - ^ aChar = $x - ifTrue: [self removeSelection] - ifFalse: [super inspectorKey: aChar from: view].! Item was removed: - ----- Method: CollectionInspector>>objectSize (in category 'private') ----- - objectSize - "For robustness. Partially initialized collections may fail to report their size. Useful for the debugger's inspectors." - - ^ [self object size] ifError: [0]! Item was removed: - ----- Method: CollectionInspector>>removeSelectedElement (in category 'menu - commands') ----- - removeSelectedElement - - self object remove: self selection.! Item was removed: - ----- Method: CollectionInspector>>removeSelection (in category 'menu - commands') ----- - removeSelection - "Keep the selection stable to support subsequent removals. Be robust against collections that do not allow elements to be removed such as arrays." - - | priorSelectionIndex | - super removeSelection. - - self assertElementSelectedOr: [^ self changed: #flash]. - priorSelectionIndex := self selectionIndex. - - [self removeSelectedElement] - ifError: [^ self changed: #flash]. - - self updateFields. - self selectionIndex: (priorSelectionIndex min: self fields size).! Item was removed: - ----- Method: CollectionInspector>>requestObject:initialAnswer:orCancel: (in category 'ui requests') ----- - requestObject: aMessageString initialAnswer: anAnswerString orCancel: aBlock - - | input | - input := Project uiManager - request: aMessageString - initialAnswer: anAnswerString. - input isEmptyOrNil ifTrue: [^ aBlock value]. - ^ Compiler evaluate: input for: self object! Item was removed: - ----- Method: CollectionInspector>>requestObject:orCancel: (in category 'ui requests') ----- - requestObject: aMessageString orCancel: aBlock - - ^ self - requestObject: aMessageString - initialAnswer: String empty - orCancel: aBlock! Item was removed: - ----- Method: CollectionInspector>>selectElementAt: (in category 'selection') ----- - selectElementAt: index - - self selectFieldSuchThat: [:field | field type = #element and: [field key = index]].! Item was removed: - ----- Method: CollectionInspector>>selectedElementIndex (in category 'selection') ----- - selectedElementIndex - - self assertElementSelectedOr: [^ nil]. - ^ self selectedField key! Item was removed: - ----- Method: CollectionInspector>>streamElementsOn: (in category 'fields - streaming') ----- - streamElementsOn: aStream - "Create a field for each element in the collection. Use the index' #printString (and not #asString) to reveal the nature of the key, which are usually integers (1, 2, 3, ...), but can be symbols (#apple, #tree, ...) or other objects (aMorph, aSocket, ...) in dictionary-like collections. Maybe #storeString would be even better but can be very expensive to compute." - - self - streamOn: aStream - truncate: self elementIndices - collectFields: [:index | - (self newFieldForType: #element key: index) - name: (self elementNameAt: index); - valueGetter: (self elementGetterAt: index); - valueSetter: (self elementSetterAt: index); - yourself]! Item was removed: - ----- Method: CollectionInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') ----- - streamIndexedVariablesOn: aStream - "Override to rename 'index variables' to the collection's 'elements'." - - self streamElementsOn: aStream.! Item was removed: - ----- Method: CompiledBlock>>blockExtentsToTempsMap (in category '*Tools-Debugger-support') ----- - blockExtentsToTempsMap - ^self homeMethod blockExtentsToTempsMap! Item was removed: - ----- Method: CompiledBlock>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'CompiledBlock'! Item was removed: - ----- Method: CompiledBlock>>debuggerMap (in category '*Tools-Debugger-support') ----- - debuggerMap - ^self homeMethod debuggerMap! Item was removed: - ----- Method: CompiledBlock>>startKey (in category '*Tools-Debugger-support') ----- - startKey - "The startKey is used as a key to identify the active sequence of temporaries for a block or - method in a DebuggerMethodMapForClosureCompiledMethod's startKeysToTempRefs map." - ^self! Item was removed: - ----- Method: CompiledCode>>abstractPCForConcretePC: (in category '*Tools-Debugger-support') ----- - abstractPCForConcretePC: concretePC - "Answer the abstractPC matching concretePC." - - | abstractPC scanner client endPC | - self flag: 'belongs in DebuggerMethodMap?'. - abstractPC := 1. - scanner := InstructionStream on: self. - client := InstructionClient new. - "cache endPC for methods with embedded source; finding out the endPC is very slow in this case..." - endPC := self endPC. - [(scanner pc > endPC - or: [scanner pc >= concretePC]) ifTrue: - [^abstractPC]. - abstractPC := abstractPC + 1. - scanner interpretNextInstructionFor: client] repeat! Item was removed: - ----- Method: CompiledCode>>concretePCForAbstractPC: (in category '*Tools-Debugger-support') ----- - concretePCForAbstractPC: abstractPCQuery - "Answer the concretePC matching abstractPC." - - | abstractPC scanner client endPC | - self flag: 'belongs in DebuggerMethodMap?'. - abstractPC := 1. - scanner := InstructionStream on: self. - client := InstructionClient new. - "cache endPC for methods with embedded source; finding out the endPC is very slow in this case..." - endPC := self endPC. - [abstractPC >= abstractPCQuery ifTrue: - [^scanner pc]. - abstractPC := abstractPC + 1. - scanner interpretNextInstructionFor: client. - scanner pc < endPC] whileTrue. - ^endPC! Item was removed: - ----- Method: CompiledCode>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^ CompiledCodeInspector! Item was removed: - Inspector subclass: #CompiledCodeInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !CompiledCodeInspector commentStamp: 'ct 1/12/2020 15:21' prior: 0! - I am an inspector specialized for inspecting CompiledMethods.! Item was removed: - ----- Method: CompiledCodeInspector>>fieldByteCodes (in category 'fields') ----- - fieldByteCodes - - ^ (self newFieldForType: #all key: #byteCodes) - name: 'all bytecodes' translated; emphasizeName; - valueGetter: [:object | object symbolic]; printValueAsIs; - yourself! Item was removed: - ----- Method: CompiledCodeInspector>>fieldDecompile (in category 'fields') ----- - fieldDecompile - - ^ (self newFieldForType: #code key: #decompile) - name: 'decompiled' translated; emphasizeName; - valueGetter: [:compiledCode | compiledCode decompile decompileString]; printValueAsIs; - yourself! Item was removed: - ----- Method: CompiledCodeInspector>>fieldHeader (in category 'fields') ----- - fieldHeader - - ^ (self newFieldForType: #misc key: #header) - name: 'header' translated; emphasizeName; - valueGetter: [:object | object headerDescription]; printValueAsIs; - yourself! Item was removed: - ----- Method: CompiledCodeInspector>>fieldSource (in category 'fields') ----- - fieldSource - - ^ (self newFieldForType: #code key: #source) - name: 'source code' translated; emphasizeName; - valueGetter: [:compiledCode | '"{1}"\{2}' withCRs format: {compiledCode methodClass. compiledCode getSource}]; printValueAsIs; - shouldStyleValue: true; - yourself! Item was removed: - ----- Method: CompiledCodeInspector>>streamBaseFieldsOn: (in category 'fields - streaming') ----- - streamBaseFieldsOn: aStream - "Instead of 'all inst vars' show all byte codes and header summary." - - aStream - nextPut: self fieldSelf; - nextPut: self fieldSource; - nextPut: self fieldDecompile; - nextPut: self fieldByteCodes; - nextPut: self fieldHeader.! Item was removed: - ----- Method: CompiledCodeInspector>>streamByteCodesOn: (in category 'fields - streaming') ----- - streamByteCodesOn: aStream - - self - streamOn: aStream - truncate: (self object initialPC to: self object size) - collectFields: [:pc | - (self newFieldForType: #bytecode key: pc) - valueGetter: [:compiledCode | compiledCode at: pc]; - flag: #dangerous; "mt: We might want to disallow inadvertent changes here..." - valueSetter: [:compiledCode :bytecode | compiledCode at: pc put: bytecode; voidCogVMState]; - yourself]! Item was removed: - ----- Method: CompiledCodeInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') ----- - streamIndexedVariablesOn: aStream - "Separate all indexed variables in literals and byte codes." - - self - streamLiteralsOn: aStream; - streamByteCodesOn: aStream.! Item was removed: - ----- Method: CompiledCodeInspector>>streamLiteralsOn: (in category 'fields - streaming') ----- - streamLiteralsOn: aStream - - self flag: #decompile. "mt: Use #to: and #do: instead of #to:do: to avoid inlining to preserve bindings in enumeration block for later decompilation. See InspectorField." - (1 to: self object numLiterals) do: [:index | - aStream nextPut: ((self newFieldForType: #literal key: index) - name: 'literal' , index; - valueGetter: [:compiledCode | compiledCode literalAt: index]; - flag: #dangerous; "mt: We might want to disallow inadvertent changes here..." - valueSetter: [:compiledCode :literal | compiledCode literalAt: index put: literal; voidCogVMState]; - yourself)].! Item was removed: - ----- Method: CompiledCodeInspector>>updateStyler:requestor: (in category 'user interface - styling') ----- - updateStyler: aStyler requestor: anObject - "Overridden to configure the styler to parse method source code correctly." - - | parseAMethod classOrMetaClass | - self selectedField - ifNil: [super updateStyler: aStyler requestor: anObject] - ifNotNil: [:field | - (anObject knownName = #valuePane and: [field type = #code]) - ifTrue: [parseAMethod := true. classOrMetaClass := self object methodClass] - ifFalse: [parseAMethod := false. classOrMetaClass := self doItReceiver class]. - - aStyler - environment: self environment; - classOrMetaClass: classOrMetaClass; - context: self doItContext; - parseAMethod: parseAMethod]. - - ! Item was removed: - ----- Method: CompiledMethod>>blockExtentsToTempsMap (in category '*Tools-Debugger-support') ----- - blockExtentsToTempsMap - "If the receiver has been copied with temp names answer a - map from blockExtent to temps map in the same format as - BytecodeEncoder>>blockExtentsToTempNamesMap. if the - receiver has not been copied with temps answer nil." - ^self holdsTempNames ifTrue: - [self mapFromBlockKeys: (self debuggerMap startKeysToBlockExtents values sort: [:assocA :assocB| assocA first <= assocB first]) - toSchematicTemps: self tempNamesString]! Item was removed: - ----- Method: CompiledMethod>>browse (in category '*Tools-Browsing') ----- - browse - - ^ ToolSet browseMethod: self! Item was removed: - ----- Method: CompiledMethod>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'CompiledMethod'! Item was removed: - ----- Method: CompiledMethod>>debuggerMap (in category '*Tools-Debugger-support') ----- - debuggerMap - ^DebuggerMethodMap forMethod: self! Item was removed: - ----- Method: CompiledMethod>>startKey (in category '*Tools-Debugger-support') ----- - startKey - "The startKey is used as a key to identify the active sequence of temporaries for a block or - method in a DebuggerMethodMapForClosureCompiledMethod's startKeysToTempRefs map." - ^self initialPC! Item was removed: - ----- Method: CompiledMethod>>tempsSubSequenceFrom: (in category '*Tools-Debugger-support') ----- - tempsSubSequenceFrom: tempNamesStream - ^Array streamContents: - [:tsss| - [tempNamesStream skipSeparators. - tempNamesStream atEnd - or: ['[]()' includes: tempNamesStream peek]] whileFalse: - [tsss nextPut: (String streamContents: - [:s| - [s nextPut: tempNamesStream next. - tempNamesStream peek - ifNil: [true] - ifNotNil: [:peek| ' []()' includes: peek]] whileFalse])]] - - "thisContext method tempsSubSequenceFrom: 'les temps perdu(sont n''est pas la)' readStream" - "thisContext method tempsSubSequenceFrom: ('les temps perdu(sont n''est pas la)' readStream skipTo: $(; yourself)"! Item was removed: - ----- Method: Context>>errorReportOn: (in category '*Tools-debugger access') ----- - errorReportOn: strm - "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." - - | cnt aContext startPos | - strm print: Date today; space; print: Time now; cr. - strm cr. - strm nextPutAll: 'VM: '; - nextPutAll: Smalltalk platformName asString; - nextPutAll: ' - '; - nextPutAll: Smalltalk asString; - cr. - strm nextPutAll: 'Image: '; - nextPutAll: SystemVersion current version asString; - nextPutAll: ' ['; - nextPutAll: Smalltalk lastUpdateString asString; - nextPutAll: ']'; - cr. - strm cr. - SecurityManager default printStateOn: strm. - - "Note: The following is an open-coded version of Context>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." - cnt := 0. startPos := strm position. - aContext := self. - [aContext notNil and: [(cnt := cnt + 1) < 20]] whileTrue: - [aContext printDetails: strm. "variable values" - strm cr. - aContext := aContext sender]. - - strm cr; nextPutAll: '--- The full stack ---'; cr. - aContext := self. - cnt := 0. - [aContext == nil] whileFalse: - [cnt := cnt + 1. - cnt = 20 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. - strm print: aContext; cr. "just class>>selector" - - "exit early if too long..." - strm position > (startPos+ self class maxLengthForASingleDebugLogReport) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. cnt > self class maxStackDepthForASingleDebugLogReport ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. - aContext := aContext sender] - ! Item was removed: - ----- Method: Context>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ ContextInspector! Item was removed: - ----- Method: Context>>namedTempAt: (in category '*Tools-debugger access') ----- - namedTempAt: index - "Answer the value of the temp at index in the receiver's sequence of tempNames." - ^self debuggerMap namedTempAt: index in: self! Item was removed: - ----- Method: Context>>namedTempAt:put: (in category '*Tools-debugger access') ----- - namedTempAt: index put: aValue - "Set the value of the temp at index in the receiver's sequence of tempNames. - (Note that if the value is a copied value it is also set out along the lexical chain, - but alas not in along the lexical chain.)." - ^self debuggerMap namedTempAt: index put: aValue in: self! Item was removed: - ----- Method: Context>>print:on: (in category '*Tools-debugger access') ----- - print: anObject on: aStream - "Safely print anObject in the face of direct ProtoObject subclasses." - | objClass title | - objClass := self objectClass: anObject. - (objClass canUnderstand: #printOn:) ifTrue: - [^anObject printOn: aStream]. - title := objClass name. - aStream - nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); - nextPutAll: title! Item was removed: - ----- Method: Context>>startKey (in category '*Tools-debugger access') ----- - startKey - "The startKey is used as a key to identify the active sequence of temporaries for a block or - method in a DebuggerMethodMapForClosureCompiledMethod's startKeysToTempRefs map." - ^closureOrNil - ifNil: [method initialPC] - ifNotNil: [closureOrNil isFullBlock - ifTrue: [method] - ifFalse: [closureOrNil startpc]]! Item was removed: - ----- Method: Context>>tempNames (in category '*Tools-debugger access') ----- - tempNames - "Answer a SequenceableCollection of the names of the receiver's temporary - variables, which are strings." - - ^ self debuggerMap tempNamesForContext: self! Item was removed: - ----- Method: Context>>tempsAndValues (in category '*Tools-debugger access') ----- - tempsAndValues - "Return a string of the temporary variables and their current values" - ^self debuggerMap tempsAndValuesForContext: self! Item was removed: - ----- Method: Context>>tempsAndValuesContractedTo: (in category '*Tools-debugger access') ----- - tempsAndValuesContractedTo: width - "Return a string of the temporary variables and their current values" - ^self debuggerMap tempsAndValuesForContext: self contractTo: width! Item was removed: - ----- Method: Context>>tempsAndValuesLimitedTo:indent: (in category '*Tools-debugger access') ----- - tempsAndValuesLimitedTo: sizeLimit indent: indent - "Return a string of the temporary variabls and their current values" - - | aStream | - aStream := WriteStream on: (String new: 100). - self tempNames - withIndexDo: [:title :index | - indent timesRepeat: [aStream tab]. - aStream nextPutAll: title; nextPut: $:; space; tab. - aStream nextPutAll: - ((self namedTempAt: index) printStringLimitedTo: (sizeLimit - 3 - title size max: 1)). - aStream cr]. - ^aStream contents! Item was removed: - Inspector subclass: #ContextInspector - instanceVariableNames: '' - classVariableNames: 'CachedStackTopLabel CachedTempVarsLabel' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !ContextInspector commentStamp: 'ct 1/12/2020 15:26' prior: 0! - I am an Inspector that is specialized for inspecting Contexts.! Item was removed: - ----- Method: ContextInspector>>allTempVarsTranslated (in category 'private') ----- - allTempVarsTranslated - "Alas translation is slow enough that we notice the slow down in trying to step in the debugger..." - (CurrentLocale ~= Locale current - or: [CachedTempVarsLabel isNil]) ifTrue: - [CurrentLocale := Locale current. - CachedTempVarsLabel := 'all temp vars' translated]. - ^CachedTempVarsLabel! Item was removed: - ----- Method: ContextInspector>>defaultIntegerBase (in category 'user interface') ----- - defaultIntegerBase - "Answer the default base in which to print integers. - Defer to the class of the instance." - - ^ (self object receiver class respondsTo: #defaultIntegerBaseInDebugger) - ifTrue: [self object receiver class perform: #defaultIntegerBaseInDebugger] - ifFalse: [10]! Item was removed: - ----- Method: ContextInspector>>stackTopTranslated (in category 'private') ----- - stackTopTranslated - "Alas translation is slow enough that we notice the slow down in trying to step in the debugger..." - (CurrentLocale ~= Locale current - or: [CachedStackTopLabel isNil]) ifTrue: - [CurrentLocale := Locale current. - CachedStackTopLabel := 'stack top' translated]. - ^CachedStackTopLabel! Item was removed: - ----- Method: ContextInspector>>streamFieldsOn: (in category 'fields - streaming') ----- - streamFieldsOn: aStream - - self object ifNil: [ - ^ self streamError: 'Cannot inspect a nil context' translated on: aStream]. - self object method ifNil: [ - ^ self streamError: 'Cannot inspect a context with nil method' translated on: aStream]. - - super streamFieldsOn: aStream.! Item was removed: - ----- Method: ContextInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') ----- - streamIndexedVariablesOn: aStream - "Just show (indexed) stack variables to the list." - - self streamStackVariablesOn: aStream.! Item was removed: - ----- Method: ContextInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') ----- - streamInstanceVariablesOn: aStream - "Add (named) temporary variables to the list." - - super streamInstanceVariablesOn: aStream. - self streamTemporaryVariablesOn: aStream.! Item was removed: - ----- Method: ContextInspector>>streamStackVariablesOn: (in category 'fields - streaming') ----- - streamStackVariablesOn: aStream - "If this context's stack pointer is not valid, silently skip streaming fields for stack variables. Do not stream an error field because freshly created or terminated contexts can be like this." - - self object stackPtr ifNil: [^ self]. - - self flag: #decompile. "mt: Use #to: and #do: instead of #to:do: to avoid inlining to preserve bindings in enumeration block for later decompilation. See InspectorField." - (self object numTemps + 1 to: self object stackPtr) do: [:index | - aStream nextPut: ((self newFieldForType: #stackItem key: index) - name: 'stack', index; deEmphasizeName; - valueGetter: [:object | object at: index]; - valueSetter: [:object :value | object at: index put: value]; - yourself)]! Item was removed: - ----- Method: ContextInspector>>streamTemporaryVariablesOn: (in category 'fields - streaming') ----- - streamTemporaryVariablesOn: aStream - - | tempNames | - tempNames := [self object tempNames] ifError: [ - ^ self streamError: 'Invalid temporaries' translated on: aStream]. - - tempNames withIndexDo: [:name :index | - aStream nextPut: ((self newFieldForType: #tempVar key: name) - name: ('[{1}]' format: {name}); - valueGetter: [:context | context namedTempAt: index]; - valueSetter: [:context :value | context namedTempAt: index put: value]; - yourself)]! Item was removed: - ContextInspector subclass: #ContextVariablesInspector - instanceVariableNames: '' - classVariableNames: 'ShowStackVariables' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !ContextVariablesInspector commentStamp: 'mt 3/25/2020 16:32' prior: 0! - I am an inspector that is specialized to inspecting the variables of a Context. I am typically displayed as part of a Debugger, where I sit besides an inspector for the receiver object. That's why a traditional Contextinspector would not work because it makes "ThisContext" be "self". - - At some point, this should subclass from Contextinspector.! Item was removed: - ----- Method: ContextVariablesInspector class>>showStackVariables (in category 'preferences') ----- - showStackVariables - <preference: 'Show stack variables in debugger' - category: #debug - description: 'When true, append the unnamed stack variables (if any) below the named temps in the debugger''s context inspector.' - type: #Boolean> - ^ ShowStackVariables ifNil: [false]! Item was removed: - ----- Method: ContextVariablesInspector class>>showStackVariables: (in category 'preferences') ----- - showStackVariables: aBoolean - - ShowStackVariables := aBoolean.! Item was removed: - ----- Method: ContextVariablesInspector>>doItContext (in category 'code') ----- - doItContext - - ^object! Item was removed: - ----- Method: ContextVariablesInspector>>doItReceiver (in category 'code') ----- - doItReceiver - - ^object ifNotNil: [object receiver]! Item was removed: - ----- Method: ContextVariablesInspector>>expressionForField: (in category 'private') ----- - expressionForField: anInspectorField - "Use #ThisContext instead of #self. Note the capital 'T' to not refer to the special keyword #thisContext, which would return the current execution context but not the one we are currently inspecting." - - ^ anInspectorField expressionWithReceiverName: #ThisContext! Item was removed: - ----- Method: ContextVariablesInspector>>fieldAllTempVars (in category 'fields') ----- - fieldAllTempVars - - ^ (self newFieldForType: #all key: #allTempVars) - name: self allTempVarsTranslated; emphasizeName; - valueGetter: [:object | object tempsAndValuesContractedTo: 64]; printValueAsIs; - yourself! Item was removed: - ----- Method: ContextVariablesInspector>>fieldSelf (in category 'fields') ----- - fieldSelf - - ^ super fieldSelf - name: 'thisContext'; - yourself! Item was removed: - ----- Method: ContextVariablesInspector>>fieldStackTop (in category 'fields') ----- - fieldStackTop - - ^ (self newFieldForType: #stackTop key: #stackTop) - name: self stackTopTranslated; emphasizeName; - valueGetter: [:ctxt | ctxt top]; - valueGetterExpression: 'ThisContext top'; - valueSetter: [:ctxt :value | ctxt pop; push: value]; - valueSetterExpression: '[:value | ThisContext pop; push: value]'; - yourself! Item was removed: - ----- Method: ContextVariablesInspector>>streamBaseFieldsOn: (in category 'fields - streaming') ----- - streamBaseFieldsOn: aStream - - self object ifNil: [^ self]. - aStream nextPut: self fieldSelf. - self object actualStackSize > 0 - ifTrue: [aStream nextPut: self fieldStackTop]. - aStream nextPut: self fieldAllTempVars.! Item was removed: - ----- Method: ContextVariablesInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') ----- - streamIndexedVariablesOn: aStream - - self class showStackVariables ifTrue: [ - self streamStackVariablesOn: aStream].! Item was removed: - ----- Method: ContextVariablesInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') ----- - streamInstanceVariablesOn: aStream - "Just show the (named) temporary variables to the list. Hide internals. The receiver is in the debugger's companion inspector." - - self streamTemporaryVariablesOn: aStream.! Item was removed: - ----- Method: ContextVariablesInspector>>streamTemporaryVariablesOn: (in category 'fields - streaming') ----- - streamTemporaryVariablesOn: aStream - "Overwritten to change the visuals of temps in debuggers." - - | tempNames | - tempNames := [self object tempNames] ifError: [ - ^ self streamError: 'Invalid temporaries' translated on: aStream]. - - tempNames withIndexDo: [:name :index | - aStream nextPut: ((self newFieldForType: #tempVar key: name) - shouldStyleName: true; - valueGetter: [:context | context namedTempAt: index]; - valueSetter: [:context :value | context namedTempAt: index put: value]; - yourself)].! Item was removed: - SelectionMenu subclass: #CustomMenu - instanceVariableNames: 'labels dividers lastDivider title targets arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - - !CustomMenu commentStamp: 'nice 3/24/2010 07:36' prior: 0! - I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages: - - add: aString action: anAction - addLine - - After the menu is constructed, it may be invoked with one of the following messages: - - startUp: initialSelection - startUp - - I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are: - - items := an OrderedCollection of strings to appear in the menu - selectors := an OrderedCollection of Symbols to be used as message selectors - lineArray := an OrderedCollection of line positions - lastLine := used to keep track of the last line to avoid making duplicate entries in lineArray! Item was removed: - ----- Method: CustomMenu class>>example (in category 'example') ----- - example - "CustomMenu example" - - | menu | - menu := CustomMenu new. - menu add: 'apples' action: #apples. - menu add: 'oranges' action: #oranges. - menu addLine. - menu addLine. "extra lines ignored" - menu add: 'peaches' action: #peaches. - menu addLine. - menu add: 'pears' action: #pears. - menu addLine. - ^ menu startUp: #apples - - - "NB: The following is equivalent to the above, but uses the compact #fromArray: consruct: - (CustomMenu fromArray: - #( ('apples' apples) - ('oranges' oranges) - - - - - ('peaches' peaches) - - - ('pears' pears) - -)) - startUp: #apples"! Item was removed: - ----- Method: CustomMenu>>add:action: (in category 'construction') ----- - add: aString action: actionItem - "Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client." - - | s | - aString ifNil: [^ self addLine]. - s := String new: aString size + 2. - s at: 1 put: Character space. - s replaceFrom: 2 to: s size - 1 with: aString. - s at: s size put: Character space. - labels addLast: s. - selections addLast: actionItem.! Item was removed: - ----- Method: CustomMenu>>add:subMenu:target:selector:argumentList: (in category 'compatibility') ----- - add: aString subMenu: aMenu target: target selector: aSymbol argumentList: argList - "Create a sub-menu with the given label. This isn't really a sub-menu the way Morphic does it; it'll just pop up another menu." - - self - add: aString - target: aMenu - selector: #invokeOn: - argumentList: argList asArray.! Item was removed: - ----- Method: CustomMenu>>add:target:selector: (in category 'compatibility') ----- - add: aString target: target selector: aSymbol - - self add: aString - target: target - selector: aSymbol - argumentList: #()! Item was removed: - ----- Method: CustomMenu>>add:target:selector:argument: (in category 'compatibility') ----- - add: aString target: target selector: aSymbol argument: arg - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." - - self add: aString - target: target - selector: aSymbol - argumentList: (Array with: arg)! Item was removed: - ----- Method: CustomMenu>>add:target:selector:argumentList: (in category 'compatibility') ----- - add: aString target: target selector: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument." - - self add: aString action: aSymbol. - targets addLast: target. - arguments addLast: argList asArray - ! Item was removed: - ----- Method: CustomMenu>>addLine (in category 'construction') ----- - addLine - "Append a line to the menu after the last entry. Suppress duplicate lines." - - (lastDivider ~= selections size) ifTrue: [ - lastDivider := selections size. - dividers addLast: lastDivider].! Item was removed: - ----- Method: CustomMenu>>addList: (in category 'construction') ----- - addList: listOfTuplesAndDashes - "Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc." - - listOfTuplesAndDashes do: [:aTuple | - aTuple == #- - ifTrue: [self addLine] - ifFalse: [self add: aTuple first action: aTuple second]] - - "CustomMenu new addList: #( - ('apples' buyApples) - ('oranges' buyOranges) - - - ('milk' buyMilk)); startUp" - - ! Item was removed: - ----- Method: CustomMenu>>addService:for: (in category 'compatibility') ----- - addService: aService for: serviceUser - "Append a menu item with the given service. If the item is selected, it will perform the given service." - - aService addServiceFor: serviceUser toMenu: self.! Item was removed: - ----- Method: CustomMenu>>addServices2:for:extraLines: (in category 'compatibility') ----- - addServices2: services for: served extraLines: linesArray - - services withIndexDo: [:service :i | - service addServiceFor: served toMenu: self. - (linesArray includes: i) ifTrue: [self addLine] ]! Item was removed: - ----- Method: CustomMenu>>addServices:for:extraLines: (in category 'compatibility') ----- - addServices: services for: served extraLines: linesArray - - services withIndexDo: [:service :i | - self addService: service for: served. - (linesArray includes: i) | service useLineAfter - ifTrue: [self addLine]]! Item was removed: - ----- Method: CustomMenu>>addStayUpItem (in category 'construction') ----- - addStayUpItem - "For compatibility with MenuMorph. Here it is a no-op"! Item was removed: - ----- Method: CustomMenu>>addStayUpItemSpecial (in category 'construction') ----- - addStayUpItemSpecial - "For compatibility with MenuMorph. Here it is a no-op"! Item was removed: - ----- Method: CustomMenu>>addTitle: (in category 'construction') ----- - addTitle: aString - "For compatibility with MenuMorph. Here it is a no-op"! Item was removed: - ----- Method: CustomMenu>>addTranslatedList: (in category 'construction') ----- - addTranslatedList: listOfTuplesAndDashes - "Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc. - The first element will be translated." - - listOfTuplesAndDashes do: [:aTuple | - aTuple == #- - ifTrue: [self addLine] - ifFalse: [self add: aTuple first translated action: aTuple second]] - - "CustomMenu new addTranslatedList: #( - ('apples' buyApples) - ('oranges' buyOranges) - - - ('milk' buyMilk)); startUp" - - ! Item was removed: - ----- Method: CustomMenu>>arguments (in category 'compatibility') ----- - arguments - "Answer my arguments, initializing them to an empty collection if they're found to be nil." - - ^ arguments ifNil: [arguments := OrderedCollection new]! Item was removed: - ----- Method: CustomMenu>>balloonTextForLastItem: (in category 'construction') ----- - balloonTextForLastItem: aString - "Vacuous backstop provided for compatibility with MorphicMenu"! Item was removed: - ----- Method: CustomMenu>>build (in category 'private') ----- - build - "Turn myself into an invokable ActionMenu." - - | stream | - stream := WriteStream on: (String new). - labels do: [:label | stream nextPutAll: label; cr]. - (labels isEmpty) ifFalse: [stream skip: -1]. "remove final cr" - super labels: stream contents - font: Preferences standardMenuFont - lines: dividers! Item was removed: - ----- Method: CustomMenu>>initialize (in category 'initialize-release') ----- - initialize - - labels := OrderedCollection new. - selections := OrderedCollection new. - dividers := OrderedCollection new. - lastDivider := 0. - targets := OrderedCollection new. - arguments := OrderedCollection new ! Item was removed: - ----- Method: CustomMenu>>invokeOn: (in category 'invocation') ----- - invokeOn: targetObject - "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain them from my arguments" - - ^ self invokeOn: targetObject orSendTo: nil! Item was removed: - ----- Method: CustomMenu>>invokeOn:defaultSelection: (in category 'invocation') ----- - invokeOn: targetObject defaultSelection: defaultSelection - "Invoke the menu with the given default selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen." - - | sel | - sel := self startUp: defaultSelection. - sel = nil ifFalse: [ - sel numArgs = 0 - ifTrue: [^ targetObject perform: sel] - ifFalse: [^ targetObject perform: sel with: nil]]. - ^ nil - ! Item was removed: - ----- Method: CustomMenu>>invokeOn:orSendTo: (in category 'invocation') ----- - invokeOn: targetObject orSendTo: anObject - "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain appropriately. If the recipient does not respond to the resulting message, send it to the alternate object provided" - - | aSelector anIndex recipient | - ^ (aSelector := self startUp) ifNotNil: - [anIndex := self selection. - recipient := ((targets := self targets) isEmptyOrNil or: [anIndex > targets size]) - ifTrue: - [targetObject] - ifFalse: - [targets at: anIndex]. - aSelector numArgs = 0 - ifTrue: - [recipient perform: aSelector orSendTo: anObject] - ifFalse: - [recipient perform: aSelector withArguments: (self arguments at: anIndex)]]! Item was removed: - ----- Method: CustomMenu>>labels:font:lines: (in category 'construction') ----- - labels: aString font: aFont lines: anArrayOrNil - "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." - - | labelList linesArray | - labelList := aString lines asArray. - anArrayOrNil - ifNil: [linesArray := #()] - ifNotNil: [linesArray := anArrayOrNil]. - 1 to: labelList size do: [:i | - self add: (labelList at: i) action: (labelList at: i). - (linesArray includes: i) ifTrue: [self addLine]]. - font ifNotNil: [font := aFont]. - ! Item was removed: - ----- Method: CustomMenu>>labels:lines:selections: (in category 'construction') ----- - labels: labelList lines: linesArray selections: selectionsArray - "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." - "Labels can be either a sting with embedded crs, or a collection of strings." - - | labelArray | - labelList isString - ifTrue: [labelArray := labelList lines] - ifFalse: [labelArray := labelList]. - 1 to: labelArray size do: [:i | - self add: (labelArray at: i) action: (selectionsArray at: i). - (linesArray includes: i) ifTrue: [self addLine]]. - ! Item was removed: - ----- Method: CustomMenu>>preSelect: (in category 'private') ----- - preSelect: action - "Pre-select and highlight the menu item associated with the given action." - - | i | - i := selections indexOf: action ifAbsent: [^ self]. - marker ifNil: [self computeForm]. - marker := marker - align: marker topLeft - with: (marker left)@(frame inside top + (marker height * (i - 1))). - selection := i.! Item was removed: - ----- Method: CustomMenu>>startUp (in category 'invocation') ----- - startUp - "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen." - - ^ self startUp: nil! Item was removed: - ----- Method: CustomMenu>>startUp: (in category 'invocation') ----- - startUp: initialSelection - "Build and invoke this menu with the given initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen." - - ^ self startUp: initialSelection withCaption: title! Item was removed: - ----- Method: CustomMenu>>startUp:withCaption: (in category 'invocation') ----- - startUp: initialSelection withCaption: caption - "Build and invoke this menu with the given initial selection and caption. Answer the selection associated with the menu item chosen by the user or nil if none is chosen." - - self build. - (initialSelection notNil) ifTrue: [self preSelect: initialSelection]. - ^ super startUpWithCaption: caption! Item was removed: - ----- Method: CustomMenu>>startUpWithCaption: (in category 'invocation') ----- - startUpWithCaption: caption - "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen; use the provided caption" - - ^ self startUp: nil withCaption: caption! Item was removed: - ----- Method: CustomMenu>>targets (in category 'compatibility') ----- - targets - "Answer my targets, initializing them to an empty collection if found to be nil" - - ^ targets ifNil: [targets := OrderedCollection new]! Item was removed: - ----- Method: CustomMenu>>title: (in category 'initialize-release') ----- - title: aTitle - title := aTitle! Item was removed: - CodeHolder subclass: #Debugger - instanceVariableNames: 'interruptedProcess contextStack contextStackIndex contextStackList receiverInspector receiverInspectorState contextVariablesInspector contextVariablesInspectorState externalInterrupt proceedValue selectingPC savedCursor isolationHead failedProject labelString message untilExpression terminateProcessSelector' - classVariableNames: 'CloseMeansAbandon ContextStackKeystrokes ErrorReportServer FullStackSize InterruptUIProcessIfBlockedOnErrorInBackgroundProcess NotifierStackSize SavedExtent ShowAbandonButton ShowTerminateButton StackSizeLimit WantsAnnotationPane' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !Debugger commentStamp: 'mt 12/17/2019 12:19' prior: 0! - I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. - - Special note on recursive errors: - Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. - - * A recursive error is detected. - * The current project is queried for an isolationHead - * Changes in the isolationHead are revoked - * The parent project of isolated project is returned to - * The debugger is opened there and execution resumes. - - If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. - - --- - - In September 2019, we added MorphicDebugger and MVCDebugger to untangle framework-specific features in our debugger infrastructure. However, this is just an intermediate step. The overall goal would be to remove those two subclasses again while preserving their functionality. Mostly, MVC and Morphic differ in their GUI-process management. This means that "proceed" and "close" work differently depending on the process that is being debugged. --- One idea is to attach that framework-specific information to the process objects. See Process >> #environmentAt: and #environmentAt:put:. Also see ToolSet's #handle* and #debug* methods.! Item was removed: - ----- Method: Debugger class>>closeMeansAbandon (in category 'preferences') ----- - closeMeansAbandon - <preference: 'Terminate aggressively on window closed' - categoryList: #(debug tools) - description: 'When enabled, closing the window of a full or notifier debugger will terminate the process aggressively, which means that the active unwind context (i.e., ensure-block) will not be completed. Not-yet-started unwind contexts are allowed to start and complete.' - type: #Boolean> - - ^ CloseMeansAbandon ifNil: [true]! Item was removed: - ----- Method: Debugger class>>closeMeansAbandon: (in category 'preferences') ----- - closeMeansAbandon: aBooleanOrNil - - CloseMeansAbandon := aBooleanOrNil.! Item was removed: - ----- Method: Debugger class>>errorReportServer (in category 'preferences') ----- - errorReportServer - <preference: 'Server to send error reports to' - category: 'debug' - description: 'When eToyFriendly is enabled, the debugger offers to send an error report to the developers of the system. This variable controls where this error report is sent to.' - type: #String> - ^ErrorReportServer ifNil: ['']! Item was removed: - ----- Method: Debugger class>>errorReportServer: (in category 'preferences') ----- - errorReportServer: aString - - ErrorReportServer := aString! Item was removed: - ----- Method: Debugger class>>fullStackSize (in category 'preferences') ----- - fullStackSize - - <preference: 'Stack Size in Full Debugger' - categoryList: #(debug tools) - description: 'The number of stack frames to be shown in the full debugger. You can always expand the full stack there.' - type: #Number> - - ^ FullStackSize ifNil: [20]! Item was removed: - ----- Method: Debugger class>>fullStackSize: (in category 'preferences') ----- - fullStackSize: aNumberOrNil - - FullStackSize := aNumberOrNil ifNotNil: [:num | num max: self notifierStackSize].! Item was removed: - ----- Method: Debugger class>>ifPreferredInterruptUIProcessIfBlocked: (in category 'private') ----- - ifPreferredInterruptUIProcessIfBlocked: errorWasInUIProcess - | sema | - errorWasInUIProcess ifTrue: - [^self]. - self interruptUIProcessIfBlockedOnErrorInBackgroundProcess ifFalse: - [^self]. - "Only interrupt the UI if it is unresponsive (and so is doing something that needs - interrupting). Test using addDeferredUIMessage: to see if it is running UI activities." - sema := Semaphore new. - Project current addDeferredUIMessage: [sema signal]. - (sema waitTimeoutMSecs: 100) ifTrue: - [[Project current interruptName: 'Interrupt from Background Error'] fork] - - "| s | - s := Semaphore new. - [self assert: 0 > 1000. s signal] fork. - s wait"! Item was removed: - ----- Method: Debugger class>>informExistingDebugger:label: (in category 'instance creation') ----- - informExistingDebugger: aContext label: aString - "Walking the context chain, we try to find out if we're in a debugger stepping situation. - If we find the relevant contexts, we must rearrange them so they look just like they would - if the methods were executed outside of the debugger. - hmm 8/3/2001 13:05" - | ctx quickStepMethod oldSender baseContext | - ctx := thisContext. - quickStepMethod := Context - compiledMethodAt: #quickSend:to:with:lookupIn: - ifAbsent: [Context compiledMethodAt: #quickSend:to:with:super:]. - [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: - [ctx := ctx sender]. - ctx sender ifNil: [^self]. - baseContext := ctx. - "baseContext is now the context created by the #quickSend... method." - oldSender := ctx := ctx sender home sender. - "oldSender is the context which originally sent the #quickSend... method" - [ctx == nil or: [(ctx objectClass: ctx receiver) includesBehavior: self]] whileFalse: - [ctx := ctx sender]. - ctx ifNil: [^self]. - "ctx is the context of the Debugger method #doStep" - ctx receiver - labelString: aString; - proceedValue: aContext receiver. - baseContext swapSender: baseContext sender sender sender. "remove intervening contexts" - thisContext swapSender: oldSender. "make myself return to debugger" - ^ aContext! Item was removed: - ----- Method: Debugger class>>initialize (in category 'class initialization') ----- - initialize - ContextStackKeystrokes := Dictionary new - at: $e put: #send; - at: $t put: #doStep; - at: $T put: #stepIntoBlock; - at: $p put: #proceed; - at: $r put: #restart; - at: $f put: #fullStack; - at: $w put: #where; - yourself. - SavedExtent := self new initialExtent - - "Debugger initialize"! Item was removed: - ----- Method: Debugger class>>interruptUIProcessIfBlockedOnErrorInBackgroundProcess (in category 'preferences') ----- - interruptUIProcessIfBlockedOnErrorInBackgroundProcess - <preference: 'Interrupt UI process on background error' - category: 'debug' - description: 'When enabled, the debugger will interrupt the UI process if an error occurs in a background process and the UI process is blocked.' - type: #Boolean> - ^InterruptUIProcessIfBlockedOnErrorInBackgroundProcess ifNil: [false]! Item was removed: - ----- Method: Debugger class>>interruptUIProcessIfBlockedOnErrorInBackgroundProcess: (in category 'preferences') ----- - interruptUIProcessIfBlockedOnErrorInBackgroundProcess: aBoolean - InterruptUIProcessIfBlockedOnErrorInBackgroundProcess := aBoolean! Item was removed: - ----- Method: Debugger class>>notifierStackSize (in category 'preferences') ----- - notifierStackSize - - <preference: 'Stack Size in Notifier Debugger' - categoryList: #(debug tools) - description: 'If there is no message to be displayed in the notifier, how many stack frames should be visible?' - type: #Number> - - ^ NotifierStackSize ifNil: [10]! Item was removed: - ----- Method: Debugger class>>notifierStackSize: (in category 'preferences') ----- - notifierStackSize: anInteger - - NotifierStackSize := anInteger.! Item was removed: - ----- Method: Debugger class>>openOn:context:label:contents:fullView: (in category 'opening') ----- - openOn: process context: context label: titleOrNil contents: contentsStringOrNil fullView: bool - "Kind of private. Open a notifier or a full debugger in response to an error, halt, or notify. Opens a project-specific debugger. Decorates that invocation with (1) recursive-error detection and (2) error logging, which are both independent from the active GUI framework, that is, MVC or Morphic. - - Note that clients should debug processes through Process >> #debug instead of calling this method directly." - - | ap title | - title := titleOrNil ifNil: ['Debugger' translated]. - ap := Processor activeProcess. - - "If the active process re-enters this method again, something went wrong with invoking the debugger." - ap hasRecursiveError ifTrue: [ - ap clearErrorRecursionFlag. - ^ ToolSet handleRecursiveError: title]. - - "Explicitely handle logging exceptions. No need to bother the recursion mechanism here." - [Preferences logDebuggerStackToFile - ifTrue: [Smalltalk logSqueakError: title inContext: context] - ] on: Error do: [:ex | - Preferences disable: #logDebuggerStackToFile. - ToolSet debugException: ex]. - - "If project-specific debuggers mess up, we have to flag that recursion here. Se above." - [ap setErrorRecursionFlag. - - self informExistingDebugger: context label: title. - - ^ Project current debuggerClass - openOn: process context: context label: title contents: contentsStringOrNil fullView: bool - - ] ensure: [ap clearErrorRecursionFlag].! Item was removed: - ----- Method: Debugger class>>showAbandonButton (in category 'preferences') ----- - showAbandonButton - <preference: 'Show ''Abandon'' button in notifier debugger' - categoryList: #(debug tools) - description: 'An extra button in the notifier window that allows the user to terminate the process aggressively, which means that the active unwind context (i.e., ensure-block) will not be completed. Not-yet-started unwind contexts are allowed to start and complete.' - type: #Boolean> - - ^ ShowAbandonButton ifNil: [true]! Item was removed: - ----- Method: Debugger class>>showAbandonButton: (in category 'preferences') ----- - showAbandonButton: aBooleanOrNil - - ShowAbandonButton := aBooleanOrNil.! Item was removed: - ----- Method: Debugger class>>showTerminateButton (in category 'preferences') ----- - showTerminateButton - <preference: 'Show ''Terminate'' button in notifier debugger' - categoryList: #(debug tools) - description: 'An extra button in the notifier window that allows the user to terminate the process while allowing the active context (i.e., ensure-block) to unwind first.' - type: #Boolean> - - ^ ShowTerminateButton ifNil: [false]! Item was removed: - ----- Method: Debugger class>>showTerminateButton: (in category 'preferences') ----- - showTerminateButton: aBooleanOrNil - - ShowTerminateButton := aBooleanOrNil.! Item was removed: - ----- Method: Debugger class>>stackSizeLimit (in category 'preferences') ----- - stackSizeLimit - - <preference: 'Stack Size Limit' - categoryList: #(debug tools) - description: 'Even when expanding the entire stack, there should be a limit to avoid low-space errors.' - type: #Number> - - ^ StackSizeLimit ifNil: [100000]! Item was removed: - ----- Method: Debugger class>>stackSizeLimit: (in category 'preferences') ----- - stackSizeLimit: aNumber - - StackSizeLimit := aNumber max: self fullStackSize.! Item was removed: - ----- Method: Debugger class>>wantsAnnotationPane (in category 'preferences') ----- - wantsAnnotationPane - <preference: 'Show annotation pane in the debugger.' - categoryList: #(debug tools) - description: 'If true, a small horizontal annotation pane shows information about the selected method.' - type: #Boolean> - ^ WantsAnnotationPane ifNil: [false]! Item was removed: - ----- Method: Debugger class>>wantsAnnotationPane: (in category 'preferences') ----- - wantsAnnotationPane: boolean - - WantsAnnotationPane := boolean.! Item was removed: - ----- Method: Debugger>>abandon (in category 'context stack menu') ----- - abandon - "Close the debugger and terminate the debugged process from the pre-debugger notifier window." - - self flag: #dicuss. "mt: Wouldn't it be better to let the current ensure block finish from within the pre-debugger notifier window? To use #terminate instead?" - terminateProcessSelector := #terminateAggressively. - self close - ! Item was removed: - ----- Method: Debugger>>aboutToStyle: (in category 'code pane') ----- - aboutToStyle: aStyler - "This is a notification that aStyler is about to re-style its text. - Set the classOrMetaClass in aStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - aStyler - classOrMetaClass: self selectedClassOrMetaClass; - sourceMap: self debuggerMap. - ^true! Item was removed: - ----- Method: Debugger>>addModelItemsToWindowMenu: (in category 'misc') ----- - addModelItemsToWindowMenu: aMenu - - super addModelItemsToWindowMenu: aMenu. - - aMenu addLine. - aMenu - add: 'inspect process' translated target: self interruptedProcess action: #inspect; - add: 'explore process' translated target: self interruptedProcess action: #explore; - addLine; - add: 'terminate process' translated target: self action: #terminateProcess; - balloonTextForLastItem: 'Terminates this process while allowing the active context to unwind first. Unlike ''abandon,'' even a currently active ensure-block will be allowed to finish.' translated; - add: 'abandon process' translated target: self action: #abandon; - balloonTextForLastItem: 'Terminates this process <b>aggressively</b>, still allowing not-yet-started unwind contexts to start and complete. Unlike ''terminate,'' a currently active ensure-block will be discarded. ' translated asTextFromHtml.! Item was removed: - ----- Method: Debugger>>askForCategoryIn:default: (in category 'notifier support') ----- - askForCategoryIn: aClass default: aString - - ^ (Project uiManager - chooseFromOrAddTo: (aClass allMethodCategoriesIntegratedThrough: Object) - lines: #() - title: 'Please provide a good category for the new method' translated) - ifNil: [aString] - ifNotNil: [:newCategory | newCategory ifEmpty: [aString]]! Item was removed: - ----- Method: Debugger>>askForSuperclassOf:toImplement:ifCancel: (in category 'notifier support') ----- - 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! Item was removed: - ----- Method: Debugger>>askForSuperclassOf:upTo:toImplement:ifCancel: (in category 'notifier support') ----- - askForSuperclassOf: aClass upTo: superclass toImplement: aSelector ifCancel: cancelBlock - | classes chosenClassIndex | - classes := aClass withAllSuperclasses reject: [:cls | aClass isKindOf: cls]. - chosenClassIndex := UIManager default - chooseFrom: (classes collect: [:c | c name]) - title: 'Define #', aSelector, ' in which class?'. - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - ^ classes at: chosenClassIndex! Item was removed: - ----- Method: Debugger>>browseClassHierarchy (in category 'toolbuilder') ----- - browseClassHierarchy - "Create and schedule a class list browser on the receiver's hierarchy." - - (self selectedMessageName = #doesNotUnderstand: and: [ self selectedClassOrMetaClass = Object ]) - ifTrue: - [ self systemNavigation - spawnHierarchyForClass: self receiverClass - selector: self selectedMessageName ] - ifFalse: [ super browseClassHierarchy ]! Item was removed: - ----- Method: Debugger>>browseMessages (in category 'context stack menu') ----- - browseMessages - "Present a menu of all messages sent by the currently selected message. - Open a message set browser of all implementors of the message chosen. - Do nothing if no message is chosen." - - contextStackIndex = 0 ifTrue: [^ self]. - self withSelectorAndMessagesIn: self selectedContext method - evaluate: [:selector| self systemNavigation browseAllImplementorsOf: selector]! Item was removed: - ----- Method: Debugger>>browseSendersOfMessages (in category 'context stack menu') ----- - browseSendersOfMessages - "Present a menu of the currently selected message, as well as all - messages sent by it. Open a message set browser of all senders - of the message chosen." - - contextStackIndex = 0 ifTrue: [^ self]. - self withSelectorAndMessagesIn: self selectedContext method - evaluate: [:selector| self systemNavigation browseAllCallsOn: selector]! Item was removed: - ----- Method: Debugger>>browseVersions (in category 'context stack menu') ----- - browseVersions - "Create and schedule a message set browser on all versions of the currently selected message selector." - (ToolSet - browseVersionsOf: self selectedClassOrMetaClass - selector: self selectedMessageName) ifNil: [self changed: #flash]! Item was removed: - ----- Method: Debugger>>buildCodePaneWith: (in category 'toolbuilder') ----- - buildCodePaneWith: builder - - | textSpec top controlButtons browseButtons annoSpec | - top := builder pluggablePanelSpec new. - top children: OrderedCollection new. - - controlButtons := self buildControlButtonsWith: builder. - controlButtons frame: self controlButtonsFrame. - top children add: controlButtons. - - self wantsOptionalButtons ifTrue: [ - browseButtons := self buildOptionalButtonsWith: builder. - browseButtons frame: self optionalButtonsFrame. - top children add: browseButtons]. - - textSpec := builder pluggableCodePaneSpec new. - textSpec - model: self; - getText: #contents; - setText: #contents:notifying:; - selection: #contentsSelection; - menu: #codePaneMenu:shifted:; - frame: self textFrame. - top children add: textSpec. - - self wantsAnnotationPane ifTrue: [ - annoSpec := self buildAnnotationPaneWith: builder. - annoSpec frame: self annotationFrame. - top children add: annoSpec]. - . - ^ top! Item was removed: - ----- Method: Debugger>>buildControlButtonsWith: (in category 'toolbuilder') ----- - buildControlButtonsWith: builder - - | panelSpec | - panelSpec := builder pluggablePanelSpec new. - panelSpec children: OrderedCollection new. - self customButtonSpecs do:[:spec| - | buttonSpec | - buttonSpec := builder pluggableActionButtonSpec new. - buttonSpec model: self. - buttonSpec label: spec first. - buttonSpec action: spec second. - spec second == #methodHierarchy ifTrue:[ - buttonSpec color: #inheritanceButtonColor. - ]. - spec size > 2 ifTrue: - [buttonSpec help: spec third. - spec size > 3 ifTrue: - [buttonSpec enabled: spec fourth]]. - panelSpec children add: buttonSpec. - ]. - - panelSpec layout: #horizontal. "buttons" - ^panelSpec! Item was removed: - ----- Method: Debugger>>buildFullWith: (in category 'toolbuilder') ----- - buildFullWith: builder - | windowSpec listSpec textSpec | - windowSpec := builder pluggableWindowSpec new - model: self; - label: 'Debugger'; - children: OrderedCollection new. - - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #contextStackList; - getIndex: #contextStackIndex; - setIndex: #toggleContextStackIndex:; - menu: #contextStackMenu:shifted:; - icon: #messageIconAt:; - helpItem: #messageHelpAt:; - keyPress: #contextStackKey:from:; - frame: (0 at 0 corner: 1 at 0.22). - windowSpec children add: listSpec. - - - textSpec := self buildCodePaneWith: builder. - textSpec frame: (0 at 0.22corner: 1 at 0.8). - windowSpec children add: textSpec. - - listSpec := self receiverInspector buildFieldListWith: builder. - listSpec - frame: (0 at 0.8 corner: 0.2 at 1); - help: 'Receiver''s\Instance\Variables' withCRs. - windowSpec children add: listSpec. - - textSpec := self receiverInspector buildValuePaneWith: builder. - textSpec - help: '<- Select receiver''s field' translated; - frame: (0.2 at 0.8 corner: 0.5 at 1). - windowSpec children add: textSpec. - - listSpec := self contextVariablesInspector buildFieldListWith: builder. - listSpec - frame: (0.5 at 0.8 corner: 0.7 at 1); - help: 'Other\Context\Bindings' withCRs. - windowSpec children add: listSpec. - - textSpec := self contextVariablesInspector buildValuePaneWith: builder. - textSpec - help: '<- Select context''s field' translated; - frame: (0.7 at 0.8 corner: 1 at 1). - windowSpec children add: textSpec. - - ^builder build: windowSpec! Item was removed: - ----- Method: Debugger>>buildNotifierWith:label:message: (in category 'toolbuilder') ----- - buildNotifierWith: builder label: label message: messageString - | windowSpec listSpec textSpec panelSpec quads | - windowSpec := builder pluggableWindowSpec new - model: self; - extent: self initialExtentForNotifier; - label: label asString; - children: OrderedCollection new. - - panelSpec := builder pluggablePanelSpec new. - panelSpec children: OrderedCollection new. - quads := self preDebugButtonQuads. - (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [ - quads := quads copyWith: - { 'Create'. #createMethod. #magenta. 'create the missing method' } - ]. - (#(#notYetImplemented #shouldBeImplemented #requirement) includes: self interruptedContext selector) ifTrue: [ - quads := quads copyWith: - { 'Create'. #createImplementingMethod. #magenta. 'implement the marked method' } - ]. - (self interruptedContext selector == #subclassResponsibility) ifTrue: [ - quads := quads copyWith: - { 'Create'. #createOverridingMethod. #magenta. 'create the missing overriding method' } - ]. - quads do:[:spec| | buttonSpec | - buttonSpec := builder pluggableButtonSpec new. - buttonSpec model: self. - buttonSpec label: spec first. - buttonSpec action: spec second. - buttonSpec help: spec fourth. - spec size >= 5 ifTrue: [buttonSpec enabled: spec fifth]. - panelSpec children add: buttonSpec. - ]. - panelSpec layout: #horizontal. "buttons" - panelSpec frame: self preDebugButtonQuadFrame. - windowSpec children add: panelSpec. - - Preferences eToyFriendly | messageString notNil ifFalse:[ - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #contextStackList; - getIndex: #contextStackIndex; - setIndex: #debugAt:; - icon: #messageIconAt:; - helpItem: #messageHelpAt:; - frame: self contextStackFrame. - windowSpec children add: listSpec. - ] ifTrue:[ - message := messageString. - textSpec := builder pluggableTextSpec new. - textSpec - model: self; - getText: #preDebugMessageString; - setText: nil; - selection: nil; - menu: #debugProceedMenu:; - frame: self contextStackFrame. - windowSpec children add: textSpec. - ]. - - ^windowSpec! Item was removed: - ----- Method: Debugger>>buildWith: (in category 'toolbuilder') ----- - buildWith: aBuilder - ^self buildFullWith: aBuilder! Item was removed: - ----- Method: Debugger>>checkContextSelection (in category 'private') ----- - checkContextSelection - - contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil]. - ! Item was removed: - ----- Method: Debugger>>close (in category 'initialize') ----- - close - "Close and delete this debugger. Try to trigger the close request through the UI first, do manually of not in the UI." - - self flag: #refactor. "mt: Maybe move this up to model?" - self topView - ifNotNil: [self changed: #close] - ifNil: [ - self okToClose ifTrue: [ - self windowIsClosing; release]].! Item was removed: - ----- Method: Debugger>>codePaneSelectionInterval (in category 'code pane') ----- - codePaneSelectionInterval - - ^ self codeTextPane - ifNotNil: [:cp | cp selectionInterval] - ifNil: [Interval from: 0 to: 0]! Item was removed: - ----- Method: Debugger>>contents (in category 'accessing') ----- - contents - "Depending on the current selection, different information is retrieved. - Answer a string description of that information. This information is the - method in the currently selected context." - - ^contents ifNil: - [self selectedContext - ifNotNil: [self selectedMessage] - ifNil: [String new]] ! Item was removed: - ----- Method: Debugger>>contents:notifying: (in category 'accessing') ----- - contents: aText notifying: aController - "Accept new method source of the selected context." - - | selector classOfMethod category ctxt newMethod | - contextStackIndex = 0 ifTrue: [^ false]. - - "First, handle some edge cases" - selector := self selectedClass newParser parseSelector: aText. - "selector isDoIt ifTrue: [ - currentCompiledMethod := self compileDoIt: aText]." - self flag: #todo. "ct: Recompile doIt method *without* creating method litters!! See Compiler>>#evaluateCue:ifFail:." - selector = self selectedMessageName ifFalse: [ - "Different message compiled, delegating to super" - ^ super contents: aText notifying: aController]. - - self selectedContext isExecutingBlock ifTrue: [ - "If we are in a block context, we need to rewind the stack before ." - | home | - home := self selectedContext activeHome. - home ifNil: [ - self inform: 'Method for block not found on stack, can''t edit and continue' translated. - ^ false]. - (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' translated withCRs) ifFalse: [ - ^ false]. - - self resetContext: home changeContents: false. - "N.B. Only reset the contents if the compilation succeeds. If contents would be reset when compilation fails, both compiler error message and modifications were lost." - ^ (self contents: aText notifying: aController) - ifTrue: [self contentsChanged]; - yourself]. - - classOfMethod := self selectedClass. - category := self selectedMessageCategoryName. - - "Do the actual compilation" - selector := classOfMethod - compile: aText - classified: category - notifying: aController. - selector ifNil: [^ false]. "compilation cancelled" - - "Update views" - contents := aText. - newMethod := classOfMethod compiledMethodAt: selector. - newMethod isQuick ifTrue: [ - self cutBackExecutionToSenderContext]. - ctxt := interruptedProcess popTo: self selectedContext. - ctxt == self selectedContext - ifFalse: [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' translated withCRs] - ifTrue: [ - newMethod isQuick ifFalse: [ - interruptedProcess restartTopWith: newMethod. - interruptedProcess stepToSendOrReturn]. - contextVariablesInspector object: nil]. - self resetContext: ctxt. - - Project current addDeferredUIMessage: [ - self changed: #contentsSelection]. - ^ true! Item was removed: - ----- Method: Debugger>>contentsSelection (in category 'code pane') ----- - contentsSelection - "Reverse the selection (i.e., point block and mark block) to put the text cursor at the beginning to ensure visibility of the beginning in small windows." - - self flag: #tofix. "mt: See http://forum.world.st/The-Inbox-Morphic-cmm-1615-mcz-td5109271.html and http://forum.world.st/stepping-in-small-panes-td5109239.html." - ^ self pcRange in: [:interval | - interval last + 1 to: interval first - 1]! Item was removed: - ----- Method: Debugger>>context: (in category 'initialize') ----- - context: aContext - - self - process: Processor activeProcess - context: aContext.! Item was removed: - ----- Method: Debugger>>contextStackFrame (in category 'toolbuilder') ----- - contextStackFrame - - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: self buttonHeight; - rightFraction: 1 offset: 0; - bottomFraction: 1 offset: 0! Item was removed: - ----- Method: Debugger>>contextStackIndex (in category 'context stack - message list') ----- - contextStackIndex - "Answer the index of the selected context." - - ^contextStackIndex! Item was removed: - ----- Method: Debugger>>contextStackIndex:oldContextWas: (in category 'private') ----- - contextStackIndex: anInteger oldContextWas: oldContext - "Change the context stack index to anInteger, perhaps in response to user selection." - - | isNewMethod | - self saveReceiverInspectorState. - self saveContextVariablesInspectorState. - contextStackIndex := anInteger. - anInteger = 0 ifTrue: - [currentCompiledMethod := contents := nil. - self changed: #contextStackIndex. - self decorateButtons. - self contentsChanged. - contextVariablesInspector object: nil. - receiverInspector context: nil; inspect: self receiver. - ^self]. - isNewMethod := oldContext isNil - or: [oldContext home method ~= (currentCompiledMethod := self selectedContext home method)]. - isNewMethod ifTrue: - [contents := self selectedMessage. - self contentsChanged. - self pcRange]. - self changed: #contextStackIndex. - self decorateButtons. - contextVariablesInspector object: self selectedContext. - self restoreContextVariablesInspectorState. - receiverInspector context: self selectedContext; inspect: self receiver. - self restoreReceiverInspectorState. - isNewMethod ifFalse: - [self changed: #contentsSelection]! Item was removed: - ----- Method: Debugger>>contextStackKey:from: (in category 'context stack menu') ----- - contextStackKey: aChar from: view - "Respond to a keystroke in the context list" - - | selector | - selector := ContextStackKeystrokes at: aChar ifAbsent: [nil]. - selector ifNil: [self messageListKey: aChar from: view] - ifNotNil: [self perform: selector]! Item was removed: - ----- Method: Debugger>>contextStackList (in category 'context stack - message list') ----- - contextStackList - "Answer the array of contexts." - - ^contextStackList! Item was removed: - ----- Method: Debugger>>contextStackMenu:shifted: (in category 'context stack menu') ----- - contextStackMenu: aMenu shifted: shifted - "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" - - ^ self menu: aMenu for: #(contextStackMenu contextStackMenuShifted:) shifted: shifted - ! Item was removed: - ----- Method: Debugger>>contextStackTop (in category 'accessing') ----- - contextStackTop - ^ contextStack first.! Item was removed: - ----- Method: Debugger>>contextVariablesInspector (in category 'accessing') ----- - contextVariablesInspector - "Answer the instance of Inspector that is providing a view of the - variables of the selected context." - - ^contextVariablesInspector! Item was removed: - ----- Method: Debugger>>controlButtonsFrame (in category 'toolbuilder') ----- - controlButtonsFrame - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self buttonHeight! Item was removed: - ----- Method: Debugger>>copyBugReportToClipboard (in category 'context stack menu') ----- - copyBugReportToClipboard - - | messageStream | - messageStream := WriteStream on: (String new: 1500). - self interruptedContext errorReportOn: messageStream. - Clipboard clipboardText: messageStream contents.! Item was removed: - ----- Method: Debugger>>createImplementingMethod (in category 'notifier buttons') ----- - createImplementingMethod - "Should only be called when this Debugger was created in response to a - NotYetImplemented exception. All we need to do is pop the signalling context off the stack and open the #notYetImplemented method." - | signallingContext | - self initializeFull. - signallingContext := self selectedContext sender. - "Pop the signalling context off the stack" - self resetContext: signallingContext. - self debug.! Item was removed: - ----- Method: Debugger>>createMethod (in category 'notifier buttons') ----- - createMethod - "Should only be called when this Debugger was created in response to a - MessageNotUnderstood exception. Create a stub for the method that was - missing and proceed into it." - - | msg chosenClass | - self initializeFull. - msg := self contextStackTop exceptionMessage. - chosenClass := self - askForSuperclassOf: self contextStackTop receiver class - toImplement: msg selector - ifCancel: [^self]. - self implementMissingMethod: msg inClass: chosenClass.! Item was removed: - ----- Method: Debugger>>createOverridingMethod (in category 'notifier buttons') ----- - createOverridingMethod - "Should only be called when this Debugger was created in response to a - SubclassResponsibility exception. Create a stub for the method that needs - overriding and proceed into it. Let the user only select a class in the - inheritance chain between the actual class and the class declaring the - subclassResponsibility." - | chosenClass msg category | - self initializeFull. - msg := self contextStackTop exceptionMessage. - chosenClass := self - askForSuperclassOf: self contextStackTop receiver class - upTo: self contextStackTop sender method methodClass - toImplement: msg selector - ifCancel: [^self]. - "Use the same category as the marker method." - category := self contextStackTop sender selectorCategory. - self implementOverridingMethod: msg inClass: chosenClass inCategory: category.! Item was removed: - ----- Method: Debugger>>customButtonSpecs (in category 'initialize') ----- - customButtonSpecs - "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." - - | list | - list := #(('Proceed' proceed 'Close the debugger and proceed.' interruptedProcessShouldResume) - ('Restart' restart 'Reset this context to its start.') - ('Into' stepInto 'step Into message sends' interruptedProcessIsReady) - ('Over' stepOver 'step Over message sends' interruptedProcessIsReady) - ('Through' stepThrough 'step into a block' interruptedProcessIsReady) - ('Full Stack' showFullStack 'show full stack') - ('Where' showWhere 'select current pc range') - ('Tally It' tally 'evaluate current selection and measure the time')). - (Preferences restartAlsoProceeds and: [self interruptedProcessShouldResume]) ifTrue: - [list := list collect: [:each | - each second == #restart - ifTrue: [each copy - at: 1 put: 'Proceed Here'; - at: 3 put: 'Proceed from the beginning of this context.'; - yourself] - ifFalse: [each second == #proceed - ifTrue: [each copy - at: 1 put: 'Proceed Top'; - at: 3 put: 'Proceed from the current top context.'; - yourself] - ifFalse: [each]]]]. - ^ list! Item was removed: - ----- Method: Debugger>>cutBackExecutionToSenderContext (in category 'private') ----- - cutBackExecutionToSenderContext - "When accepting a new version of a method which can't be simulated (i.e. a quick method) we - must cut back to the sender. But this is non-trivial. If the quick method has been reached via - a perform: (as it is when one uses Create to implement a method from an MNU) then the relevant - arguments won't be on the stack and we can't simply proceed without crashing the VM." - | oldContext context sel | - oldContext := self selectedContext. - self down. - context := self selectedContext. - context pc: context previousPc. - sel := context selectorToSendOrSelf. - sel numArgs = oldContext method numArgs - ifTrue: - [context push: oldContext receiver. - oldContext arguments do: - [:arg| context push: arg]] - ifFalse: - [context privRefresh; stepToSendOrReturn]! Item was removed: - ----- Method: Debugger>>debug (in category 'notifier menu') ----- - debug - "Open a full debugger." - - self openFullFromNotifier: self topView. - ! Item was removed: - ----- Method: Debugger>>debugAt: (in category 'notifier buttons') ----- - debugAt: anInteger - "Opens a full debugger with the given index selected. See #initializeFull to understand why contextStackIndex is set directly." - - contextStackIndex := anInteger. - ^ self debug! Item was removed: - ----- Method: Debugger>>debugProceedMenu: (in category 'context stack menu') ----- - debugProceedMenu: aMenu - ^ aMenu labels: - 'proceed - debug' - lines: #() - selections: #(proceed debug ) - ! Item was removed: - ----- Method: Debugger>>debuggerCodePaneMenu: (in category 'code pane menu') ----- - debuggerCodePaneMenu: aMenu - <codePaneMenu> - <menuPriority: 200> - ^ aMenu - add: 'run to here' target: self selector: #runToSelection: argument: self codePaneSelectionInterval; - add: 'run until...' target: self selector: #runUntil; - addLine; - yourself - ! Item was removed: - ----- Method: Debugger>>debuggerMap (in category 'accessing') ----- - debuggerMap - ^self selectedContext debuggerMap! Item was removed: - ----- Method: Debugger>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.9 g: 0.719 b: 0.719)! Item was removed: - ----- Method: Debugger>>doItContext (in category 'code pane') ----- - doItContext - "Answer the context in which a text selection can be evaluated." - - contextStackIndex = 0 - ifTrue: [^super doItContext] - ifFalse: [^self selectedContext]! Item was removed: - ----- Method: Debugger>>doItReceiver (in category 'code pane') ----- - doItReceiver - "Answer the object that should be informed of the result of evaluating a - text selection." - - ^self receiver! Item was removed: - ----- Method: Debugger>>doNothing: (in category 'accessing') ----- - doNothing: newText - "Notifier window can't accept text"! Item was removed: - ----- Method: Debugger>>doStep (in category 'context stack menu') ----- - doStep - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - | currentContext newContext | - self okToChange ifFalse: [^ self]. - self interruptedProcessIsReady ifFalse: [^ self shouldNotStep]. - self checkContextSelection. - currentContext := self selectedContext. - newContext := self handleLabelUpdatesIn: [interruptedProcess completeStep: currentContext] - whenExecuting: currentContext. - interruptedProcess ifNil: [^ self shouldNotStep]. - newContext == currentContext ifTrue: - [newContext := interruptedProcess stepToSendOrReturn]. - self updateProcess. - self contextStackIndex > 1 - ifTrue: [self resetContext: newContext] - ifFalse: - [newContext == currentContext - ifTrue: [self changed: #contentsSelection. - self updateInspectors] - ifFalse: [self resetContext: newContext]].! Item was removed: - ----- Method: Debugger>>doStepUntil: (in category 'context stack menu') ----- - doStepUntil: condition - "Step until the given condition evaluates to other than false, reporting an error it if does not evaluate to true. - - If shift is pressed when the expression is supplied, don't update the UI. If shift is pressed while stepping, stop stepping. Using a user interrupt to break out would be more natural but Squeak currently doesn't provide a UserInterrupt exception. It should do." - - | currentContext newContext value lastUpdate updateUI breakOnShift | - self okToChange ifFalse: [^ self]. - self interruptedProcessIsReady ifFalse: [^ self shouldNotStep]. - self checkContextSelection. - currentContext := newContext := self selectedContext. - lastUpdate := Time millisecondClockValue. - updateUI := breakOnShift := Sensor shiftPressed not. - - Cursor execute showWhile: [[ - newContext == currentContext - and: [currentContext willReturn not - and: [(value := condition value) == false]] ] whileTrue: [ - - self - handleLabelUpdatesIn: [newContext := interruptedProcess completeStep: currentContext] - whenExecuting: currentContext. - interruptedProcess ifNil: [^ self shouldNotStep]. - newContext == currentContext ifTrue: [ - newContext := interruptedProcess stepToSendOrReturn. - self resetContext: newContext changeContents: false]. - - Time millisecondClockValue - lastUpdate > 250 "ms" ifTrue: [ - updateUI ifTrue: [ - self changed: #contentsSelection. - Project current world displayWorldSafely]. - breakOnShift - ifTrue: [Sensor shiftPressed ifTrue: [ - self changed: #contentsSelection. - self updateInspectors. - ^self]] - ifFalse: [Sensor shiftPressed ifFalse: [breakOnShift := true]]. - lastUpdate := Time millisecondClockValue] ]]. - - self updateProcess. - self contextStackIndex > 1 - ifTrue: [self resetContext: newContext] - ifFalse: - [newContext == currentContext - ifTrue: [self changed: #contentsSelection; updateInspectors] - ifFalse: [self resetContext: newContext]]. - - ^ value! Item was removed: - ----- Method: Debugger>>down (in category 'context stack menu') ----- - down - "move down the context stack to the previous (enclosing) context" - - self toggleContextStackIndex: contextStackIndex+1! Item was removed: - ----- Method: Debugger>>expandNotifierStack (in category 'context stack - message list') ----- - expandNotifierStack - "Show a small amount of stack in the context pane. Useful for notifiers." - - self okToChange ifFalse: [^ self]. - self newStack: (self contextStackTop stackOfSize: self class notifierStackSize). - self changed: #contextStackList. - ! Item was removed: - ----- Method: Debugger>>expandStack (in category 'context stack - message list') ----- - expandStack - "Show a substantial amount of stack in the context pane." - - self okToChange ifFalse: [^ self]. - self newStack: (self contextStackTop stackOfSize: (self class fullStackSize max: self class notifierStackSize)). - self changed: #contextStackList. - ! Item was removed: - ----- Method: Debugger>>externalInterrupt: (in category 'private') ----- - externalInterrupt: aBoolean - - externalInterrupt := aBoolean ! Item was removed: - ----- Method: Debugger>>extraCellGap (in category 'toolbuilder') ----- - extraCellGap - "Since BorderedMorph is currently not able to add the #cellGap between *two* fixed buttons rows at the same #topFraction, add that offset here explicitely." - - self flag: #refactor. "mt: See BorderedMorph >> #changeCellGapOfLayoutFrames:." - ^ ToolBuilder default panelSpacing! Item was removed: - ----- Method: Debugger>>findCleanHomeBelow: (in category 'context stack (message list)') ----- - findCleanHomeBelow: method - - | dirtyIndex | - dirtyIndex := contextStack size + 1. - contextStack reverse detect: [:context | - dirtyIndex := dirtyIndex - 1. - context home method = method homeMethod]. - ^ dirtyIndex + 1! Item was removed: - ----- Method: Debugger>>fullStack (in category 'context stack menu') ----- - fullStack - "Change from displaying the minimal stack to a full one." - - contextStack last sender isNil - ifTrue: - ["Already expanded" - self changed: #flash] - ifFalse: - [| oldContextStackIndex | - oldContextStackIndex := contextStackIndex. - self fullyExpandStack. - oldContextStackIndex = contextStackIndex - ifFalse: - [self toggleContextStackIndex: oldContextStackIndex]]! Item was removed: - ----- Method: Debugger>>fullyExpandStack (in category 'context stack - message list') ----- - fullyExpandStack - "Expand the stack to include all of it. Well, almost all of it, we better maintain sane limits too." - - self okToChange ifFalse: [^ self]. - self newStack: (self contextStackTop stackOfSize: self class stackSizeLimit - contextStack size). - self changed: #contextStackList.! Item was removed: - ----- Method: Debugger>>getSelectedText (in category 'tally support') ----- - getSelectedText - | m interval text | - m := self codeTextPane ifNil: [^ '']. - interval := m selectionInterval. - text := m text. - ^ text copyFrom: interval first to: interval last - ! Item was removed: - ----- Method: Debugger>>handleLabelUpdatesIn:whenExecuting: (in category 'context stack menu') ----- - handleLabelUpdatesIn: aBlock whenExecuting: aContext - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - ^aBlock - on: Notification - do: [:ex| - (ex tag isArray - and: [ex tag size = 2 - and: [(ex tag first == aContext or: [ex tag first hasSender: aContext])]]) - ifTrue: - [self labelString: ex tag second description. - ex resume] - ifFalse: - [ex pass]]! Item was removed: - ----- Method: Debugger>>implementMissingMethod:inClass: (in category 'notifier support') ----- - implementMissingMethod: aMessage inClass: aClass - ^ self - implementMissingMethod: aMessage - inClass: aClass - inCategory: (self askForCategoryIn: aClass default: 'as yet unclassified').! Item was removed: - ----- Method: Debugger>>implementMissingMethod:inClass:inCategory: (in category 'notifier support') ----- - implementMissingMethod: aMessage inClass: aClass inCategory: aSymbol - "Create a stub implementation of the missing message and sew it onto the top of the stack, ensuring the context's arguments are set correctly. Debug the new context." - self pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol. - - "Cut out the sender context. This is the context that signalled the MessageNotUnderstood." - self selectedContext privSender: self selectedContext sender. - self resetContext: self selectedContext. - self debug.! Item was removed: - ----- Method: Debugger>>implementOverridingMethod:inClass:inCategory: (in category 'notifier support') ----- - implementOverridingMethod: aMessage inClass: aClass inCategory: aSymbol - "Create a stub implementation of the overriding message and sew it onto the top of the stack, ensuring the context's arguments are set correctly. Debug the new context." - self pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol. - - "Cut out the sender context. This is the context that signalled the SubclassResponsibility." - self selectedContext privSender: self selectedContext sender sender. - self resetContext: self selectedContext. - self debug.! Item was removed: - ----- Method: Debugger>>initialExtent (in category 'initialize') ----- - initialExtent - "Initial extent for the full debugger. For the notifier's extent see #initialExtentForNotifier." - - ^ SavedExtent ifNil: [ 600 at 700]! Item was removed: - ----- Method: Debugger>>initialExtentForNotifier (in category 'initialize') ----- - initialExtentForNotifier - - ^ 450 at 200! Item was removed: - ----- Method: Debugger>>initialize (in category 'initialize') ----- - initialize - - super initialize. - - Smalltalk at: #MessageTally ifPresentAndInMemory: [ :tally | - tally terminateTimerProcess]. - - externalInterrupt := false. - selectingPC := true. - - contextStackIndex := 0. - - "The default termination procedure is aggressive to ignore currently running, and thus erroneous, ensure-blocks in the debugged process. The preference can change that." - terminateProcessSelector := self class closeMeansAbandon - ifTrue: [#terminateAggressively] - ifFalse:[#terminate].! Item was removed: - ----- Method: Debugger>>initializeFull (in category 'initialize') ----- - initializeFull - "Expand the stack for the full debugger. Create inspectors." - - | oldIndex | - oldIndex := contextStackIndex. - contextStackIndex := 0. - - self expandStack. - - receiverInspector := Inspector on: nil. - contextVariablesInspector := ContextVariablesInspector on: nil. - - self toggleContextStackIndex: oldIndex.! Item was removed: - ----- Method: Debugger>>interruptedContext (in category 'accessing') ----- - interruptedContext - "Answer the suspended context of the interrupted process." - - ^self contextStackTop.! Item was removed: - ----- Method: Debugger>>interruptedProcess (in category 'accessing') ----- - interruptedProcess - "Answer the interrupted process." - - ^interruptedProcess! Item was removed: - ----- Method: Debugger>>interruptedProcessIsReady (in category 'testing') ----- - interruptedProcessIsReady - - ^ interruptedProcess notNil - and: [interruptedProcess isSuspended "do not debug the active process"] - and: [interruptedProcess isTerminated not]! Item was removed: - ----- Method: Debugger>>interruptedProcessShouldResume (in category 'testing') ----- - interruptedProcessShouldResume - - ^ self interruptedProcessIsReady and: [interruptedProcess shouldResumeFromDebugger]! Item was removed: - ----- Method: Debugger>>isFull (in category 'testing') ----- - isFull - - ^ self isNotifier not! Item was removed: - ----- Method: Debugger>>isNotifier (in category 'testing') ----- - isNotifier - - ^ receiverInspector isNil! Item was removed: - ----- Method: Debugger>>keyForContextVariablesInspectorState (in category 'user interface') ----- - keyForContextVariablesInspectorState - - ^ self contextVariablesInspector object ifNotNil: [:ctxt | ctxt method]! Item was removed: - ----- Method: Debugger>>keyForReceiverInspectorState (in category 'user interface') ----- - keyForReceiverInspectorState - - ^ self receiverInspector object! Item was removed: - ----- Method: Debugger>>labelString (in category 'accessing') ----- - labelString - ^labelString! Item was removed: - ----- Method: Debugger>>labelString: (in category 'accessing') ----- - labelString: aString - labelString := aString. - self changed: #relabel! Item was removed: - ----- Method: Debugger>>mailOutBugReport (in category 'context stack menu') ----- - mailOutBugReport - "Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - - 'Squeak could pre-fill the bug form with lots of vital, but - oft-repeated, information like what is the image version, last update - number, VM version, platform, available RAM, author...' - - and address it to the list with the appropriate subject prefix." - - MailSender default ifNil: [^self]. - - Cursor write - showWhile: - ["Prepare the message" - | messageStrm | - messageStrm := WriteStream on: (String new: 1500). - messageStrm nextPutAll: 'From: '; - nextPutAll: MailSender userName; - cr; - nextPutAll: 'To: squeak-dev at lists.squeakfoundation.org'; - cr; - nextPutAll: 'Subject: '; - nextPutAll: '[BUG]'; nextPutAll: self interruptedContext printString; - cr;cr; - nextPutAll: 'here insert explanation of what you were doing, suspect changes you''ve made and so forth.';cr;cr. - self interruptedContext errorReportOn: messageStrm. - - MailSender sendMessage: (MailMessage from: messageStrm contents)]. - ! Item was removed: - ----- Method: Debugger>>mainContextStackMenu: (in category 'context stack menu') ----- - mainContextStackMenu: aMenu - "Set up the menu appropriately for the context-stack-list, unshifted" - <contextStackMenuShifted: false> - ^ aMenu - addTranslatedList: #( - ('fullStack (f)' fullStack) - ('restart (r)' restart) - ('proceed (p)' proceed) - ('step (t)' doStep) - ('step through (T)' stepIntoBlock) - ('send (e)' send) - ('where (w)' where) - ('peel to first like this' peelToFirst) - - - ('return entered value' returnValue) - - ); - add: (self isBreakOnEntry ifTrue: ['<on>'] ifFalse: ['<off>']) , 'break on entry' translated - action: #toggleBreakOnEntry; - addTranslatedList: #( - ('senders of (n)' browseSendersOfMessages) - ('implementors of (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('references (r)' browseVariableReferences) - ('assignments (a)' browseVariableAssignments) - - - ('class refs (N)' browseClassRefs) - ('browse full (b)' browseMethodFull) - ('file out ' fileOutMessage) - ('remove method (x) ' removeMessage) - - - ('copy bug report to clipboard' copyBugReportToClipboard)); - yourself! Item was removed: - ----- Method: Debugger>>messageHelpAt: (in category 'context stack - message list') ----- - messageHelpAt: anIndex - "Show the first n lines of the sources code of the selected message." - - | method | - Preferences balloonHelpInMessageLists ifFalse: [^ nil]. - contextStack size < anIndex ifTrue: [^ nil]. - - method := (contextStack at: anIndex) method. - ^ self messageHelpForMethod: method.! Item was removed: - ----- Method: Debugger>>messageIconAt: (in category 'context stack - message list') ----- - messageIconAt: anIndex - - Browser showMessageIcons - ifFalse: [^ nil]. - - ^ ToolIcons iconNamed: (ToolIcons - iconForClass: (contextStack at: anIndex) method methodClass - selector: (contextStack at: anIndex) method selector)! Item was removed: - ----- Method: Debugger>>messageListIndex (in category 'context stack - message list') ----- - messageListIndex - "Answer the index of the currently selected context." - - ^contextStackIndex! Item was removed: - ----- Method: Debugger>>messageListMenu:shifted: (in category 'context stack menu') ----- - messageListMenu: aMenu shifted: shifted - "The context-stack menu takes the place of the message-list menu in the debugger, so pass it on" - - ^ self contextStackMenu: aMenu shifted: shifted! Item was removed: - ----- Method: Debugger>>modelWakeUpIn: (in category 'user interface') ----- - modelWakeUpIn: aWindow - - super modelWakeUpIn: aWindow. - self updateInspectors.! Item was removed: - ----- Method: Debugger>>newStack: (in category 'private') ----- - newStack: stack - | oldStack diff matchIndex | - oldStack := contextStack. - contextStack := stack. - (oldStack isNil or: [oldStack last ~~ stack last]) ifTrue: - [contextStackList := stack collect: [:ctx | ctx printString]. - ^self]. - "May be able to re-use some of previous list" - diff := stack size - oldStack size. - contextStackList := diff <= 0 - ifTrue: [contextStackList copyFrom: 1 - diff to: oldStack size] - ifFalse: - [matchIndex := stack lastIndexOf: oldStack first startingAt: diff + 1. - matchIndex = 0 - ifTrue: [contextStack collect: [:ctx | ctx printString]] - ifFalse: [((contextStack first: matchIndex - 1) collect: [:ctx| ctx printString]), contextStackList]] - "#(d e f h i) => #(a b c d e f g h i) - diff := 3. - matchIndex := 4. - #(a b c d e f g h i) := #(a b c), #(d e f h i)"! Item was removed: - ----- Method: Debugger>>openFullFromNotifier: (in category 'initialize') ----- - openFullFromNotifier: topView - "Create a full debugger with the given label. Subclasses should complete this procedure." - - self initializeFull. - - topView model: nil. "so close won't release me." - self breakDependents.! Item was removed: - ----- Method: Debugger>>openFullNoSuspendLabel: (in category 'initialize') ----- - openFullNoSuspendLabel: aString - "Create, schedule and answer a full debugger with the given label. Subclasses should complete this procedure." - - self initializeFull.! Item was removed: - ----- Method: Debugger>>openNotifierNoSuspendContents:label: (in category 'initialize') ----- - openNotifierNoSuspendContents: msgString label: label - "Create, schedule and answer a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active process has not been suspended. The sender will do this." - - savedCursor := Cursor currentCursor. - Cursor currentCursor: Cursor normal. - - self expandNotifierStack.! Item was removed: - ----- Method: Debugger>>optionalButtonsFrame (in category 'toolbuilder') ----- - optionalButtonsFrame - - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: self buttonHeight + self extraCellGap; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self buttonHeight*2 + self extraCellGap! Item was removed: - ----- Method: Debugger>>pc (in category 'code pane') ----- - pc - - ^ self pcRange! Item was removed: - ----- Method: Debugger>>pcRange (in category 'code pane') ----- - pcRange - "Answer the indices in the source code for the method corresponding to - the selected context's program counter value." - - | ctxt | - (selectingPC and: [contextStackIndex ~= 0]) ifFalse: - [^1 to: 0]. - (ctxt := self selectedContext) isDead ifTrue: - [^1 to: 0]. - ^ctxt debuggerMap - rangeForPC: ctxt pc - in: ctxt method - contextIsActiveContext: contextStackIndex = 1! Item was removed: - ----- Method: Debugger>>peelToFirst (in category 'context stack menu') ----- - peelToFirst - "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" - - | ctxt | - contextStackIndex = 0 ifTrue: [^ Beeper beep]. - "self okToChange ifFalse: [^ self]." - ctxt := interruptedProcess popTo: self selectedContext findSecondToOldestSimilarSender. - self resetContext: ctxt. - ! Item was removed: - ----- Method: Debugger>>perform:orSendTo: (in category 'code pane menu') ----- - perform: selector orSendTo: otherTarget - "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." - - | result | - (#(debug proceed) includes: selector) "When I am a notifier window" - ifTrue: [^ self perform: selector] - ifFalse: [result := super perform: selector orSendTo: otherTarget. - selector == #doIt ifTrue: [ - result ~~ #failedDoit ifTrue: [self proceedValue: result]]. - ^ result]! Item was removed: - ----- Method: Debugger>>preDebugButtonQuadFrame (in category 'toolbuilder') ----- - preDebugButtonQuadFrame - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self buttonHeight.! Item was removed: - ----- Method: Debugger>>preDebugButtonQuads (in category 'initialize') ----- - preDebugButtonQuads - - ^Preferences eToyFriendly - ifTrue: [ - { - {'Send error report' translated. #sendReport. #blue. 'send a report of the encountered problem to the Squeak developers' translated}. - {'Abandon' translated. #abandon. #black. 'abandon this execution by closing this window' translated}. - {'Debug' translated. #debug. #red. 'bring up a debugger' translated}}] - ifFalse: [ - { - {'Proceed' translated. #proceed. #blue. 'continue execution' translated. #interruptedProcessShouldResume}. - self class showTerminateButton ifTrue: [ - {'Terminate' translated. #terminateProcess. #black. 'terminate this execution and close this window' translated}]. - self class showAbandonButton ifTrue: [ - {'Abandon' translated. #abandon. #black. 'terminate this execution aggressively and close this window' translated}]. - {'Debug' translated. #debug. #red. 'bring up a debugger' translated}} - reject: [:quad | quad isNil] ] - ! Item was removed: - ----- Method: Debugger>>preDebugMessageString (in category 'toolbuilder') ----- - preDebugMessageString - ^ message ifNil: [ - String streamContents: [:s | - s nextPutAll: 'An error has occurred, sorry!! You could send the Squeak developers an error report or just hit ''Abandon''. - - In the error report, there is no personal information, only information that we can use to investigate the error. If you decide to send us the error report, it will include the following text: - - ' translated. - [s nextPutAll: self contextStackTop printString; cr. - self contextStackTop errorReportOn: s] on: Error do: [s nextPutAll: 'no text, there was an error creating the error report' translated]]].! Item was removed: - ----- Method: Debugger>>proceed (in category 'context stack menu') ----- - proceed - "Proceed from the interrupted state of the currently selected context. The argument is the topView of the receiver. That view is closed. The active process usually suspends (or terminates) after this call." - - | processToResume canResume | - - Smalltalk okayToProceedEvenIfSpaceIsLow ifFalse: [^ self]. - - self okToChange ifFalse: [^ self]. - self checkContextSelection. - - processToResume := interruptedProcess. - canResume := self interruptedProcessShouldResume. - - interruptedProcess := nil. "Before delete, so release doesn't terminate it" - self close. - - savedCursor ifNotNil: [Cursor currentCursor: savedCursor]. - Project current restoreDisplay. - - Smalltalk installLowSpaceWatcher. "restart low space handler" - - canResume - ifTrue: [self resumeProcess: processToResume] - ifFalse: [self notify: 'This process should not resume.\Debugger will close now.' withCRs].! Item was removed: - ----- Method: Debugger>>proceedValue (in category 'accessing') ----- - proceedValue - "Answer the value to return to the selected context when the interrupted - process proceeds." - - ^proceedValue! Item was removed: - ----- Method: Debugger>>proceedValue: (in category 'accessing') ----- - proceedValue: anObject - "Set the value to be returned to the selected context when the interrupted - process proceeds." - - proceedValue := anObject! Item was removed: - ----- Method: Debugger>>process:context: (in category 'initialize') ----- - process: aProcess context: aContext - - interruptedProcess := aProcess. - - self newStack: (aContext stackOfSize: 1). - contextStackIndex := 1.! Item was removed: - ----- Method: Debugger>>pushStubMethodOnStack:inClass:inCategory: (in category 'private') ----- - pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol - "Create a stub implementation of the message and sew it onto the top of the stack, ensuring the context's arguments are set correctly." - aClass - compile: aMessage createStubMethod - classified: aSymbol. - self setContentsToForceRefetch. - self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage numArgs > 0 ifTrue: - [aMessage arguments withIndexDo: - [:arg :index| - self selectedContext tempAt: index put: arg]].! Item was removed: - ----- Method: Debugger>>receiver (in category 'accessing') ----- - receiver - "Answer the receiver of the selected context, if any. Answer nil - otherwise." - - contextStackIndex = 0 - ifTrue: [^nil] - ifFalse: [^self selectedContext receiver]! Item was removed: - ----- Method: Debugger>>receiverClass (in category 'toolbuilder') ----- - receiverClass - ^ self selectedContext receiver class! Item was removed: - ----- Method: Debugger>>receiverInspector (in category 'accessing') ----- - receiverInspector - "Answer the instance of Inspector that is providing a view of the - variables of the selected context's receiver." - - ^receiverInspector! Item was removed: - ----- Method: Debugger>>removeMessage (in category 'context stack menu') ----- - removeMessage - - | oldContext method cleanIndex | - self okToChange ifFalse: [^ false]. - contextStackIndex isZero ifTrue: [^ false]. - - oldContext := self selectedContext. - method := oldContext method. - cleanIndex := self findCleanHomeBelow: method. - contextStack at: cleanIndex ifAbsent: [ - self inform: 'Sender of method not found on stack, can''t remove message'. - ^ false]. - self interruptedProcessIsReady ifFalse: [^ self shouldNotStep]. - (self confirm: 'I will have to revert to the sender of this message. Is that OK?') - ifFalse: [^ false]. - - super removeMessage ifFalse: [^ false]. - self - contextStackIndex: cleanIndex oldContextWas: oldContext; - tryRestartFrom: self selectedContext. - - ^ true! Item was removed: - ----- Method: Debugger>>resetContext: (in category 'private') ----- - resetContext: aContext - ^ self resetContext: aContext changeContents: true! Item was removed: - ----- Method: Debugger>>resetContext:changeContents: (in category 'private') ----- - resetContext: aContext changeContents: aBoolean - "Used when a new context becomes top-of-stack, for instance when the - method of the selected context is re-compiled, or the simulator steps or - returns to a new method. There is room for much optimization here, first - to save recomputing the whole stack list (and text), and secondly to avoid - recomposing all that text (by editing the paragraph instead of recreating it)." - - | oldContext | - oldContext := self selectedContext. - self newStack: (aContext ifNil: [oldContext]) contextStack. - self changed: #contextStackList. - self contextStackIndex: 1 oldContextWas: oldContext. - self updateProcess. - aBoolean ifTrue: [self contentsChanged].! Item was removed: - ----- Method: Debugger>>restart (in category 'context stack menu') ----- - restart - "Proceed from the initial state of the currently selected context. The - argument is a controller on a view of the receiver. That view is closed." - "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" - - | unwindError | - self okToChange ifFalse: [^ self]. - interruptedProcess isSuspended ifFalse: [^ self shouldNotStep]. - self checkContextSelection. - unwindError := self tryRestartFrom: self selectedContext. - ((Preferences restartAlsoProceeds - and: [unwindError not]) - and: [self interruptedProcessShouldResume]) - ifTrue: [self proceed].! Item was removed: - ----- Method: Debugger>>restoreContextVariablesInspectorState (in category 'user interface') ----- - restoreContextVariablesInspectorState - "For the user's convenience. Save field selection and user-typed content in the context-variables inspector. See #saveContextVariablesInspectorState." - - contextVariablesInspectorState ifNotNil: [:stateForAll | - self keyForContextVariablesInspectorState ifNotNil: [:keyForState | - stateForAll - at: keyForState - ifPresent: [:state | - self contextVariablesInspector selectFieldNamed: state first. - state second ifNotNil: [:contentsTyped | - self contextVariablesInspector - setContentsTyped: contentsTyped]]]].! Item was removed: - ----- Method: Debugger>>restoreReceiverInspectorState (in category 'user interface') ----- - restoreReceiverInspectorState - "For the user's convenience. Restore field selection and user-typed content in the receiver inspector. See #saveReceiverInspectorState." - - receiverInspectorState ifNotNil: [:stateForAll | - self keyForReceiverInspectorState ifNotNil: [:keyForState | - stateForAll - at: keyForState - ifPresent: [:state | - self receiverInspector selectFieldNamed: state first. - state second ifNotNil: [:contentsTyped | - self receiverInspector - setContentsTyped: contentsTyped]]]].! Item was removed: - ----- Method: Debugger>>resumeProcess: (in category 'private') ----- - resumeProcess: aProcess - "Subclusses may override this to avoid having duplicate UI processes." - - aProcess resume.! Item was removed: - ----- Method: Debugger>>returnValue (in category 'context stack menu') ----- - returnValue - "Force a return of a given value to the previous context!!" - - | previous selectedContext expression value | - contextStackIndex = 0 ifTrue: [^Beeper beep]. - selectedContext := self selectedContext. - expression := UIManager default request: 'Enter expression for return value:'. - value := Compiler new - evaluate: expression - in: selectedContext - to: selectedContext receiver. - previous := selectedContext sender. - self resetContext: previous. - interruptedProcess popTo: previous value: value! Item was removed: - ----- Method: Debugger>>runToSelection: (in category 'code pane menu') ----- - runToSelection: selectionInterval - - self pc first >= selectionInterval first ifTrue: [ ^self ]. - self doStepUntil: [ self pc first >= selectionInterval first ].! Item was removed: - ----- Method: Debugger>>runUntil (in category 'code pane menu') ----- - runUntil - "Step until an expression evaluates to other than false, reporting an error if it doesn't evaluate to true. Remember the expression in an inst var." - - | expression receiver context method value | - expression := UIManager default - request: 'run until expression is true (shift to disable ui update; shift to break).' - initialAnswer: (untilExpression ifNil: 'boolean expression'). - (expression isNil or: [expression isEmpty]) ifTrue: - [^self]. - untilExpression := expression. - context := self selectedContext. - receiver := context receiver. - method := receiver class evaluatorClass new - compiledMethodFor: untilExpression - in: context - to: receiver - notifying: nil - ifFail: [^ #failedDoit]. - - value := self doStepUntil: [method valueWithReceiver: receiver arguments: {context}]. - - (value ~~ self and: [value ~~ false and: [value ~~ true]]) ifTrue: - [UIManager default inform: 'expression ', (untilExpression contractTo: 40), ' answered ', (value printString contractTo: 20), '!!!!']! Item was removed: - ----- Method: Debugger>>saveContextVariablesInspectorState (in category 'user interface') ----- - saveContextVariablesInspectorState - "For the user's convenience. Save field selection and user-typed content in the context-variables inspector. See #restoreContextVariablesInspectorState." - - | stateToSave keyForState | - self flag: #duplication. - (keyForState := self keyForContextVariablesInspectorState) - ifNil: [^ self]. - contextVariablesInspectorState - ifNil: [contextVariablesInspectorState := WeakIdentityKeyDictionary new]. - stateToSave := { - self contextVariablesInspector selectedFieldName. - self contextVariablesInspector contentsTyped }. - contextVariablesInspectorState - at: keyForState - put: stateToSave.! Item was removed: - ----- Method: Debugger>>saveReceiverInspectorState (in category 'user interface') ----- - saveReceiverInspectorState - "For the user's convenience. Save field selection and user-typed content in the receiver inspector. See #restoreReceiverInspectorState." - - | stateToSave keyForState | - self flag: #duplication. - (keyForState := self keyForReceiverInspectorState) - ifNil: [^ self]. - receiverInspectorState - ifNil: [receiverInspectorState := WeakIdentityKeyDictionary new]. - stateToSave := { - self receiverInspector selectedFieldName. - self receiverInspector contentsTyped }. - receiverInspectorState - at: keyForState - put: stateToSave.! Item was removed: - ----- Method: Debugger>>selectPC (in category 'context stack menu') ----- - selectPC - "Toggle the flag telling whether to automatically select the expression - currently being executed by the selected context." - - selectingPC := selectingPC not! Item was removed: - ----- Method: Debugger>>selectedClass (in category 'class list') ----- - selectedClass - "Answer the class in which the currently selected context's method was - found." - - ^self selectedContext methodClass! Item was removed: - ----- Method: Debugger>>selectedClassOrMetaClass (in category 'class list') ----- - selectedClassOrMetaClass - "Answer the class in which the currently selected context's method was - found." - - ^self selectedClass! Item was removed: - ----- Method: Debugger>>selectedContext (in category 'private') ----- - selectedContext - - contextStackIndex = 0 - ifTrue: [^contextStack first] - ifFalse: [^contextStack at: contextStackIndex]! Item was removed: - ----- Method: Debugger>>selectedMessage (in category 'context stack - message list') ----- - selectedMessage - "Answer the source code of the currently selected context." - | aContext | - ^contents := (aContext := self selectedContext) debuggerMap sourceText asText makeSelectorBoldIn: aContext home receiver class! Item was removed: - ----- Method: Debugger>>selectedMessageCategoryName (in category 'message category list') ----- - selectedMessageCategoryName - "Answer the name of the message category of the message of the - currently selected context." - - ^self selectedClass organization categoryOfElement: self selectedMessageName! Item was removed: - ----- Method: Debugger>>selectedMessageName (in category 'context stack - message list') ----- - selectedMessageName - "Answer the message selector of the currently selected context. - If the method is unbound we can still usefully answer its old selector." - - | selector | - selector := self selectedContext selector. - ^(selector ~~ self selectedContext method selector - and: [selector beginsWith: 'DoIt']) - ifTrue: [self selectedContext method selector] - ifFalse: [selector]! Item was removed: - ----- Method: Debugger>>send (in category 'context stack menu') ----- - send - "Send the selected message in the accessed method, and take control in - the method invoked to allow further step or send." - - self okToChange ifFalse: [^ self]. - self interruptedProcessIsReady ifFalse: [^ self shouldNotStep]. - self checkContextSelection. - interruptedProcess step: self selectedContext. - interruptedProcess ifNil: [^ self shouldNotStep]. - self resetContext: interruptedProcess stepToSendOrReturn.! Item was removed: - ----- Method: Debugger>>sendReport (in category 'notifier menu') ----- - sendReport - [| errorReport | - errorReport := String streamContents: [:s | - s nextPutAll: self contextStackTop printString; cr. - self contextStackTop errorReportOn: s]. - (Smalltalk classNamed: #WebClient) - ifNotNil: [:wc | - wc - httpPost: self class errorReportServer - content: errorReport - type: 'text/plain']] on: Error do: ["nothing"]. - self abandon.! Item was removed: - ----- Method: Debugger>>shiftedContextStackMenu: (in category 'context stack menu') ----- - shiftedContextStackMenu: aMenu - "Set up the menu appropriately for the context-stack-list, shifted" - <contextStackMenuShifted: true> - ^ aMenu addList: #( - ('browse class hierarchy' browseClassHierarchy) - ('browse class' browseClass) - ('implementors of sent messages' browseAllMessages) - ('change sets with this method' findMethodInChangeSets) - - - ('inspect instances' inspectInstances) - ('inspect subinstances' inspectSubInstances) - - - ('revert to previous version' revertToPreviousVersion) - ('remove from current change set' removeFromCurrentChanges) - ('revert & remove from changes' revertAndForget)); - yourself - ! Item was removed: - ----- Method: Debugger>>shouldNotStep (in category 'private') ----- - shouldNotStep - "An illegal attempt was to step an unready process. Update the enablement of stepping buttons and trigger a visual indication. - - For instance, this situation can be triggered by this: - [self currentHand lastEvent shiftPressed] yourself - whileFalse: [Project current world doOneCycleNow]. - Debug it, step over #whileFalse: and step over again. Move your cursor while pressing shift to continue." - - self - changed: #interruptedProcessIsReady; - changed: #interruptedProcessShouldResume. - - ^ self changed: #flash! Item was removed: - ----- Method: Debugger>>showFullStack (in category 'actions - convenience') ----- - showFullStack - - self fullStack.! Item was removed: - ----- Method: Debugger>>showWhere (in category 'actions - convenience') ----- - showWhere - "Select the PC range" - - self where.! Item was removed: - ----- Method: Debugger>>stepInto (in category 'actions - convenience') ----- - stepInto - - self send.! Item was removed: - ----- Method: Debugger>>stepIntoBlock (in category 'context stack menu') ----- - stepIntoBlock - "Send messages until you return to the present method context. - Used to step into a block in the method." - - | currentContext newContext | - self okToChange ifFalse: [^ self]. - self interruptedProcessIsReady ifFalse: [^ self shouldNotStep]. - self checkContextSelection. - currentContext := self selectedContext. - self handleLabelUpdatesIn: - [interruptedProcess stepToHome: currentContext] - whenExecuting: self selectedContext. - interruptedProcess ifNil: [^ self shouldNotStep]. - newContext := interruptedProcess stepToSendOrReturn. - self updateProcess. - self contextStackIndex > 1 - ifTrue: [self resetContext: newContext] - ifFalse: - [newContext == currentContext - ifTrue: [self changed: #contentsSelection. - self updateInspectors] - ifFalse: [self resetContext: newContext]].! Item was removed: - ----- Method: Debugger>>stepOver (in category 'actions - convenience') ----- - stepOver - - self doStep.! Item was removed: - ----- Method: Debugger>>stepThrough (in category 'actions - convenience') ----- - stepThrough - - self stepIntoBlock.! Item was removed: - ----- Method: Debugger>>storeLog (in category 'notifier menu') ----- - storeLog - - Smalltalk logSqueakError: labelString printString inContext: self contextStackTop - ! Item was removed: - ----- Method: Debugger>>tally (in category 'tally support') ----- - tally - - self codeTextPane ifNotNil: [:o | o tallyIt] ifNil: [Beeper beep] - ! Item was removed: - ----- Method: Debugger>>tallyMenu: (in category 'controls') ----- - tallyMenu: aMenu - - ^ aMenu - "title: 'Tally' translated;" flag: #todo; "ct: Implement on PluggableMenuSpec" - addTranslatedList: #( - ('Tally selection' tallyIt 'evaluate current selection and measure the time') - ('Record send' doRecord 'record next message send')); - yourself! Item was removed: - ----- Method: Debugger>>terminateProcess (in category 'context stack menu') ----- - terminateProcess - "Close the debugger and terminate the debugged process. Note that we use #terminate instead of #terminateAggressively to let any current ensure-block finish." - - terminateProcessSelector := #terminate. - self close - ! Item was removed: - ----- Method: Debugger>>textFrame (in category 'toolbuilder') ----- - textFrame - - ^ super textFrame - topOffset: (self wantsOptionalButtons ifTrue: [self buttonHeight * 2 + self extraCellGap] ifFalse: [self buttonHeight]); - yourself! Item was removed: - ----- Method: Debugger>>toggleBreakOnEntry (in category 'breakpoints') ----- - toggleBreakOnEntry - "Override to rset to the new breakless method if stopped at a break point. - N.B. does not (yet) do the reverse." - | ctxt prevPC atInitialBreak newMethod | - ((ctxt := self selectedContext) isNil - or: [(prevPC := ctxt previousPc) isNil]) ifTrue: - [^super toggleBreakOnEntry]. - - atInitialBreak := ctxt selectorJustSentOrSelf == #break - and: [(ctxt method pcPreviousTo: ctxt previousPc) = ctxt method initialPC]. - super toggleBreakOnEntry. - newMethod := ctxt method methodReference compiledMethod. - (atInitialBreak - and: [newMethod isCompiledCode - and: [newMethod ~~ ctxt method]]) ifTrue: - [ctxt privRefreshWith: newMethod. - self resetContext: ctxt. - self debug]! Item was removed: - ----- Method: Debugger>>toggleContextStackIndex: (in category 'context stack - message list') ----- - toggleContextStackIndex: anInteger - "If anInteger is the same as the index of the selected context, deselect it. - Otherwise, the context whose index is anInteger becomes the selected - context." - - self contextStackIndex: - (contextStackIndex = anInteger - ifTrue: [0] - ifFalse: [anInteger]) - oldContextWas: - (contextStackIndex = 0 - ifTrue: [nil] - ifFalse: [contextStack at: contextStackIndex])! Item was removed: - ----- Method: Debugger>>tryRestartFrom: (in category 'context stack menu') ----- - tryRestartFrom: context - "Try to restart from the initial state of the context. - Return whether an unwind error occurred." - - | actualContext unwindError | - actualContext := interruptedProcess popTo: context. - unwindError := actualContext ~= context. - unwindError ifFalse: [ - interruptedProcess restartTop; stepToSendOrReturn]. - self resetContext: actualContext. - ^ unwindError! Item was removed: - ----- Method: Debugger>>up (in category 'context stack menu') ----- - up - "move up the context stack to the next (enclosed) context" - - contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]! Item was removed: - ----- Method: Debugger>>updateInspectors (in category 'self-updating') ----- - updateInspectors - "Update the inspectors on the receiver's variables." - - receiverInspector == nil ifFalse: [receiverInspector update]. - contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]! Item was removed: - ----- Method: Debugger>>updateProcess (in category 'private') ----- - updateProcess - - self - changed: #interruptedProcessIsReady; - changed: #interruptedProcessShouldResume.! Item was removed: - ----- Method: Debugger>>wantsAnnotationPane (in category 'toolbuilder') ----- - wantsAnnotationPane - - ^ self class wantsAnnotationPane! Item was removed: - ----- Method: Debugger>>wantsCodeProvenanceButton (in category 'toolbuilder') ----- - wantsCodeProvenanceButton - - ^ false! Item was removed: - ----- Method: Debugger>>wantsOptionalButtons (in category 'toolbuilder') ----- - wantsOptionalButtons - "The debugger benefits so majorly from the optional buttons that there is an extra preference for it." - - ^ Preferences extraDebuggerButtons! Item was removed: - ----- Method: Debugger>>wantsStepsIn: (in category 'self-updating') ----- - wantsStepsIn: aWindow - - ^ false! Item was removed: - ----- Method: Debugger>>where (in category 'context stack menu') ----- - where - "Select the expression whose evaluation was interrupted." - - selectingPC := true. - self contextStackIndex: contextStackIndex oldContextWas: self selectedContext - ! Item was removed: - ----- Method: Debugger>>windowIsClosing (in category 'initialize') ----- - windowIsClosing - "My window is being closed; clean up. Restart the low space watcher." - - contextStack := nil. - receiverInspector := nil. - contextVariablesInspector := nil. - - interruptedProcess == nil ifTrue: [^ self]. - self flag: #discuss. "mt: Maybe #fork the termination of the process. - See - - http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-May/220675.html - - http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-June/221044.html" - interruptedProcess perform: terminateProcessSelector. - interruptedProcess := nil. - - Smalltalk installLowSpaceWatcher. "restart low space handler"! Item was removed: - ----- Method: Debugger>>windowReqNewLabel: (in category 'user interface') ----- - windowReqNewLabel: newLabel - - labelString := newLabel. - ^ true! Item was removed: - Object subclass: #DebuggerMethodMap - instanceVariableNames: 'timestamp methodReference methodNode startKeysToBlockExtents abstractSourceRanges sortedSourceMap' - classVariableNames: 'AccessLock MapCache MapCacheEntries' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !DebuggerMethodMap commentStamp: 'eem 10/1/2020 19:08' prior: 0! - I am a place-holder for information needed by the Debugger to inspect method activations. I insulate the debugger from details of code generation such as exact bytecode offsets and temporary variable locations. I have two concrete subclasses, one for methods where block bytecodes are embedded in the home method and one for methods where blocks are separate objects (CompiledBlock). These classes deal with temporary variable access. My function is to abstract the source map away from actual bytecode pcs to abstract bytecode pcs. I used to have a subclass for "BlueBook" compiled methods, with non-closure blocks, but this was removed in October 2020 for simplicity's sake. - - To reduce compilation time I try and defer as much computation to access time as possible as instances of me will be created after each compilation. - - I maintain a WeakIdentityDictionary of method to DebuggerMethodMap to cache maps. I refer to my method through a WeakArray to keep the map cache functional. If the reference from a DebuggerMethodMap to its method were strong then the method would never be dropped from the cache because the reference from its map would keep it alive.! Item was removed: - ----- Method: DebuggerMethodMap class>>cacheDebugMap:forMethod: (in category 'debugger support') ----- - cacheDebugMap: aDebuggerMethodMap forMethod: aCompiledMethod - - ^self protected: [ - MapCache size >= MapCacheEntries ifTrue: [ - MapCache slowSize >= MapCacheEntries - ifFalse: [ MapCache rehash ] - ifTrue: [ - | mapsByAge | - mapsByAge := MapCache keys sort: [ :m1 :m2 | - "We are holding strongly on the keys, so #at: is suitable." - (MapCache at: m1) timestamp < (MapCache at: m2) timestamp]. - mapsByAge from: 1 to: mapsByAge size - MapCacheEntries do: [ :each | - MapCache removeKey: each ] ] ]. - MapCache - at: aCompiledMethod - put: aDebuggerMethodMap ]! Item was removed: - ----- Method: DebuggerMethodMap class>>cleanUp (in category 'class initialization') ----- - cleanUp - self initialize! Item was removed: - ----- Method: DebuggerMethodMap class>>forMethod: (in category 'instance creation') ----- - forMethod: aMethod "<CompiledMethod>" - "Answer a DebuggerMethodMap suitable for debugging activations of aMethod. - Answer an existing instance from the cache if it exists, cacheing a new one if required." - - ^self protected: [ - MapCache - at: aMethod - ifAbsent: [self - cacheDebugMap: - (self - forMethod: aMethod - methodNode: aMethod methodNode) - forMethod: aMethod] ]! Item was removed: - ----- Method: DebuggerMethodMap class>>forMethod:methodNode: (in category 'instance creation') ----- - forMethod: aMethod "<CompiledCode>" methodNode: methodNode "<MethodNode>" - "Uncached instance creation method for private use or for tests. - Please consider using forMethod: instead." - ^(aMethod encoderClass supportsFullBlocks - ifTrue: [DebuggerMethodMapForFullBlockCompiledMethods] - ifFalse: [DebuggerMethodMapForClosureCompiledMethods]) new - forMethod: aMethod homeMethod - methodNode: methodNode! Item was removed: - ----- Method: DebuggerMethodMap class>>initialize (in category 'class initialization') ----- - initialize - "DebuggerMethodMap initialize" - - self voidMapCache! Item was removed: - ----- Method: DebuggerMethodMap class>>protected: (in category 'synchronization') ----- - protected: aBlock - - ^(AccessLock ifNil: [ AccessLock := Mutex new ]) critical: aBlock! Item was removed: - ----- Method: DebuggerMethodMap class>>voidMapCache (in category 'class initialization') ----- - voidMapCache - - self protected: [ - MapCache := WeakIdentityKeyDictionary new. - MapCacheEntries := 16 ]! Item was removed: - ----- Method: DebuggerMethodMap>>abstractSourceMap (in category 'private') ----- - abstractSourceMap - "Answer with a Dictionary of abstractPC <Integer> to sourceRange <Interval>." - | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client | - abstractSourceRanges ifNotNil: - [^abstractSourceRanges]. - "If the methodNode hasn't had a method generated it doesn't have pcs set in its - nodes so we must generate a new method and might as well use it for scanning." - methodNode rawSourceRangesAndMethodDo: - [:ranges :method| - rawSourceRanges := ranges. - theMethodToScan := method]. - concreteSourceRanges := Dictionary new. - rawSourceRanges keysAndValuesDo: - [:node :range| - node pc ~= 0 ifTrue: - [concreteSourceRanges at: node pc put: range]]. - abstractPC := 1. - abstractSourceRanges := Dictionary new. - scanner := InstructionStream on: theMethodToScan. - client := InstructionClient new. - [(concreteSourceRanges includesKey: scanner pc) ifTrue: - [abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)]. - abstractPC := abstractPC + 1. - scanner interpretNextInstructionFor: client. - scanner atEnd] whileFalse. - ^abstractSourceRanges! Item was removed: - ----- Method: DebuggerMethodMap>>abstractSourceMapForMethod: (in category 'source mapping') ----- - abstractSourceMapForMethod: aCompiledMethod - "The default source mapping is for block bytecodes embedded within a - single compiled method, as in the BlueBook and EncoderForV3PlusClosures." - ^self abstractSourceMap! Item was removed: - ----- Method: DebuggerMethodMap>>blockExtentsInto:from:to:method:numberer: (in category 'private') ----- - blockExtentsInto: aDictionary from: initialPC to: endPC method: method numberer: numbererBlock - "Support routine for startpcsToBlockExtents" - | pcs extentStart locator scanner blockSizeOrMethodOrLocator | - extentStart := numbererBlock value. - locator := BlockStartLocator new. - scanner := InstructionStream new method: method pc: initialPC. - pcs := OrderedCollection new. - [pcs addLast: scanner pc. - scanner pc <= endPC] whileTrue: - [blockSizeOrMethodOrLocator := scanner interpretNextInstructionFor: locator. - blockSizeOrMethodOrLocator ~~ locator ifTrue: - [blockSizeOrMethodOrLocator isInteger - ifTrue: - [self - blockExtentsInto: aDictionary - from: scanner pc - to: scanner pc + blockSizeOrMethodOrLocator - 1 - method: method - numberer: numbererBlock. - scanner pc: scanner pc + blockSizeOrMethodOrLocator] - ifFalse: - [self assert: blockSizeOrMethodOrLocator isCompiledBlock. - self - blockExtentsInto: aDictionary - from: blockSizeOrMethodOrLocator initialPC - to: blockSizeOrMethodOrLocator endPC - method: blockSizeOrMethodOrLocator - numberer: numbererBlock]]]. - aDictionary - at: (method isCompiledBlock - ifTrue: [method] - ifFalse: [initialPC]) - put: (extentStart to: numbererBlock value). - ^aDictionary! Item was removed: - ----- Method: DebuggerMethodMap>>forMethod:methodNode: (in category 'initialize-release') ----- - forMethod: aMethod "<CompiledMethod>" methodNode: theMethodNode "<MethodNode>" - methodReference := WeakArray with: aMethod. - methodNode := theMethodNode. - self markRecentlyUsed! Item was removed: - ----- Method: DebuggerMethodMap>>markRecentlyUsed (in category 'private') ----- - markRecentlyUsed - timestamp := Time totalSeconds! Item was removed: - ----- Method: DebuggerMethodMap>>method (in category 'accessing') ----- - method - ^methodReference at: 1! Item was removed: - ----- Method: DebuggerMethodMap>>namedTempAt:in: (in category 'accessing') ----- - namedTempAt: index in: aContext - "Answer the value of the temp at index in aContext where index is relative - to the array of temp names answered by tempNamesForContext:" - self assert: aContext method homeMethod == self method. - ^self - privateTempAt: index - in: aContext - startKeysToBlockExtents: self startKeysToBlockExtents! Item was removed: - ----- Method: DebuggerMethodMap>>namedTempAt:put:in: (in category 'accessing') ----- - namedTempAt: index put: aValue in: aContext - "Assign the value of the temp at index in aContext where index is relative - to the array of temp names answered by tempNamesForContext:. - If the value is a copied value we also need to set it along the lexical chain." - self assert: aContext method homeMethod == self method. - ^self - privateTempAt: index - in: aContext - put: aValue - startKeysToBlockExtents: self startKeysToBlockExtents! Item was removed: - ----- Method: DebuggerMethodMap>>rangeForPC:in:contextIsActiveContext: (in category 'source mapping') ----- - rangeForPC: contextsConcretePC in: method contextIsActiveContext: contextIsActiveContext - "Answer the indices in the source code for the supplied pc. - If the context is the actve context (is at the hot end of the stack) - then its pc is the current pc. But if the context isn't, because it is - suspended sending a message, then its current pc is the previous pc." - - | pc abstractMap i end | - pc := method abstractPCForConcretePC: (contextIsActiveContext - ifTrue: [contextsConcretePC] - ifFalse: [(method pcPreviousTo: contextsConcretePC) - ifNotNil: [:prevpc| prevpc] - ifNil: [contextsConcretePC]]). - abstractMap := self abstractSourceMapForMethod: method. - (abstractMap includesKey: pc) ifTrue: - [^abstractMap at: pc]. - sortedSourceMap ifNil: - [sortedSourceMap := abstractMap associations - replace: [ :each | each copy ]; - sort]. - sortedSourceMap isEmpty ifTrue: [^1 to: 0]. - i := sortedSourceMap findNearbyBinaryIndex: [:assoc| pc - assoc key]. - i < 1 ifTrue: [^1 to: 0]. - i > sortedSourceMap size ifTrue: - [end := sortedSourceMap inject: 0 into: - [:prev :this | prev max: this value last]. - ^end+1 to: end]. - ^(sortedSourceMap at: i) value - - "| method source scanner map | - method := DebuggerMethodMap compiledMethodAt: #rangeForPC:in:contextIsActiveContext:. - source := method getSourceFromFile asString. - scanner := InstructionStream on: method. - map := method debuggerMap. - Array streamContents: - [:ranges| - [scanner atEnd] whileFalse: - [| range | - range := map rangeForPC: scanner pc in: method contextIsActiveContext: true. - ((map abstractSourceMap includesKey: scanner abstractPC) - and: [range first ~= 0]) ifTrue: - [ranges nextPut: (source copyFrom: range first to: range last)]. - scanner interpretNextInstructionFor: InstructionClient new]]"! Item was removed: - ----- Method: DebuggerMethodMap>>sourceText (in category 'source mapping') ----- - sourceText - self method ifNotNil: - [:method| - method holdsTempNames ifTrue: - [^method - getSourceFor: (method selector ifNil: [method defaultSelector]) - in: method methodClass]]. - ^methodNode sourceText! Item was removed: - ----- Method: DebuggerMethodMap>>startKeysToBlockExtents (in category 'private') ----- - startKeysToBlockExtents - "Answer the map from start keys (either start pcs for embedded closures, or - full block methods for full blocks) to the block extents in that method, where - a block extent is an abstract representation of block nesting within a method." - - startKeysToBlockExtents ifNil: - [| index method | - index := 0. - method := self method homeMethod. - startKeysToBlockExtents := - self - blockExtentsInto: self newBlockStartMap - from: method initialPC - to: method endPC - method: method - numberer: [| value | value := index. index := index + 2. value]]. - ^startKeysToBlockExtents! Item was removed: - ----- Method: DebuggerMethodMap>>tempNamesForContext: (in category 'accessing') ----- - tempNamesForContext: aContext - "Answer an Array of all the temp names in scope in aContext starting with - the home's first local (the first argument or first temporary if no arguments)." - self assert: aContext method homeMethod == self method. - ^(self - privateTempRefsForContext: aContext - startKeysToBlockExtents: self startKeysToBlockExtents) collect: - [:pair| pair first]! Item was removed: - ----- Method: DebuggerMethodMap>>tempNamesForMethod: (in category 'accessing') ----- - tempNamesForMethod: aMethod - "Answer an Array of all the temp names in scope in aMethod starting with - the home's first local (the first argument or first temporary if no arguments)." - self assert: aMethod homeMethod == self method. - ^(self - privateTempRefsForMethod: aMethod - startKeysToBlockExtents: self startKeysToBlockExtents) collect: - [:pair| pair first]! Item was removed: - ----- Method: DebuggerMethodMap>>tempsAndValuesForContext: (in category 'accessing') ----- - tempsAndValuesForContext: aContext - "Return a string of the temporary variables and their current values" - | aStream | - aStream := WriteStream on: (String new: 100). - (self tempNamesForContext: aContext) withIndexDo: - [:title :index | - aStream nextPutAll: title; nextPut: $:; space; tab. - aContext print: (self namedTempAt: index in: aContext) on: aStream. - aStream cr]. - ^aStream contents! Item was removed: - ----- Method: DebuggerMethodMap>>tempsAndValuesForContext:contractTo: (in category 'accessing') ----- - tempsAndValuesForContext: aContext contractTo: width - "Return a string of the temporary variabls and their current values" - | aStream tempStream | - aStream := WriteStream on: (String new: 100). - tempStream := WriteStream on: (String new: width). - (self tempNamesForContext: aContext) withIndexDo: - [:title :index | - aStream nextPutAll: title; nextPut: $:; space; tab. - tempStream reset. - aContext print: (self namedTempAt: index in: aContext) on: tempStream. - aStream nextPutAll: (tempStream contents contractTo: width). - aStream cr]. - ^aStream contents! Item was removed: - ----- Method: DebuggerMethodMap>>timestamp (in category 'private') ----- - timestamp - ^timestamp! Item was removed: - DebuggerMethodMap subclass: #DebuggerMethodMapForClosureCompiledMethods - instanceVariableNames: 'blockExtentsToTempRefs startpcsToTempRefs startKeysToTempRefs' - classVariableNames: 'FirstTime' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !DebuggerMethodMapForClosureCompiledMethods commentStamp: 'eem 10/1/2020 19:19' prior: 0! - I am a place-holder for information needed by the Debugger to inspect method activations. See my superclass's comment. I map methods compiled using closures whose bytecodes are embedded within the home CompiledMethod, as is the case for the V3PlusClosures bytecode set. - - Instance variables - blockExtentsToTempsRefs <Dictionary of: Interval -> Array of: (Array with: String with: (Integer | (Array with: Integer with: Integer)))> - maps a block extent to an Array of temp references for that block/method. - Each reference is a pair of temp name and index, where the index can itself be a pair for a remote temp. - startKeysToTempRefs <Dictionary of: Integer startpc -> Array of: (Array with: String with: temp reference)> where - temp reference ::= Integer - | (Array with: Integer with: Integer) - | (Array with: #outer with: temp reference)! Item was removed: - ----- Method: DebuggerMethodMapForClosureCompiledMethods>>newBlockStartMap (in category 'private') ----- - newBlockStartMap - "If blocks are embedded then keys in the map are simple integer pcs and a Dictionary can be used. - If blocks are full (separate method objects) then keys in the map are CompiledBlocks and - IdentityDictionary must be used to avoid confusing blocks with identical code." - ^Dictionary new! Item was removed: - ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateDereference:in: (in category 'private') ----- - privateDereference: tempReference in: aContext - "Fetch the temporary with reference tempReference in aContext. - tempReference can be - integer - direct temp reference - #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index - #( outer. temp reference ) - a temp reference in an outer context." - ^tempReference isInteger - ifTrue: - [tempReference <= aContext stackPtr ifTrue: - [aContext tempAt: tempReference]] - ifFalse: - [tempReference first == #outer - ifTrue: - [self privateDereference: tempReference last - in: aContext outerContext] - ifFalse: "If stopped before indirection vectors are created they will be nil. Simply answer nil" - [tempReference first <= aContext stackPtr ifTrue: - [(aContext tempAt: tempReference first) ifNotNil: - [:indirectionVector| - indirectionVector at: tempReference second]]]]! Item was removed: - ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateDereference:in:put: (in category 'private') ----- - privateDereference: tempReference in: aContext put: aValue - "Assign the temporary with reference tempReference in aContext. - tempReference can be - integer - direct temp reference - #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index - #( outer. temp reference ) - a temp reference in an outer context." - ^tempReference isInteger - ifTrue: - [tempReference <= aContext stackPtr - ifTrue: - [aContext tempAt: tempReference put: aValue] - ifFalse: - [UIManager default inform: 'Cannot assign temp because it is no longer on stack.\Activation has returned?' withCRs. - nil]] - ifFalse: - [tempReference first == #outer - ifTrue: - [self privateDereference: tempReference last - in: aContext outerContext - put: aValue] - ifFalse: "If stopped before indirection vectors are created they will be nil." - [tempReference first <= aContext stackPtr - ifTrue: - [(aContext tempAt: tempReference first) - ifNil: [UIManager default inform: 'Cannot assign remote temp because indirection vector is nil.\Too early in method execution?' withCRs. - nil] - ifNotNil: - [:indirectionVector| - indirectionVector - at: tempReference second - put: aValue]] - ifFalse: - [UIManager default inform: 'Cannot assign remote temp because it is no longer on stack.\Activation has returned?' withCRs. - nil]]]! Item was removed: - ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempAt:in:put:startKeysToBlockExtents: (in category 'private') ----- - privateTempAt: index in: aContext put: aValue startKeysToBlockExtents: theContextsStartKeysToBlockExtents - | nameRefPair | - nameRefPair := (self privateTempRefsForContext: aContext - startKeysToBlockExtents: theContextsStartKeysToBlockExtents) - at: index - ifAbsent: [aContext errorSubscriptBounds: index]. - ^self privateDereference: nameRefPair last in: aContext put: aValue! Item was removed: - ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempAt:in:startKeysToBlockExtents: (in category 'private') ----- - privateTempAt: index in: aContext startKeysToBlockExtents: theContextsStartKeysToBlockExtents - | nameRefPair | - nameRefPair := (self privateTempRefsForContext: aContext - startKeysToBlockExtents: theContextsStartKeysToBlockExtents) - at: index - ifAbsent: [aContext errorSubscriptBounds: index]. - ^self privateDereference: nameRefPair last in: aContext! Item was removed: - ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempRefsForContext:startKeysToBlockExtents: (in category 'private') ----- - privateTempRefsForContext: aContext startKeysToBlockExtents: theContextsStartKeysToBlockExtents - "Answer the sequence of temps in scope in aContext in the natural order, - outermost arguments and temporaries first, innermost last. Each temp is - a pair of the temp's name followed by a reference. The reference can be - integer - index of temp in aContext - #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index in aContext - #( outer. temp reference ) - a temp reference in an outer context." - blockExtentsToTempRefs ifNil: - [blockExtentsToTempRefs := (aContext method holdsTempNames - ifTrue: [aContext method] - ifFalse: [methodNode]) blockExtentsToTempsMap. - blockExtentsToTempRefs - ifNil: ["an empty method. shouldn't be able to step into here but it - can happen in weird circumstances (i.e. with MethodWrapper)." - blockExtentsToTempRefs := Dictionary new. - blockExtentsToTempRefs - at: (theContextsStartKeysToBlockExtents at: aContext startKey) - put: {}] - ifNotNil: - [(blockExtentsToTempRefs isKindOf: IdentityDictionary) ifTrue: - [blockExtentsToTempRefs := Dictionary withAll: blockExtentsToTempRefs associations]]. - startKeysToTempRefs := self newBlockStartMap]. - ^startKeysToTempRefs - at: aContext startKey - ifAbsentPut: - [| localRefs | - localRefs := blockExtentsToTempRefs at: (theContextsStartKeysToBlockExtents at: aContext startKey) ifAbsent: [#()]. - aContext outerContext - ifNil: [localRefs] - ifNotNil: - [:outer| | outerTemps | - "Present temps in the order outermost to innermost left-to-right, but replace - copied outermost temps with their innermost copies" - outerTemps := (self - privateTempRefsForContext: outer - startKeysToBlockExtents: theContextsStartKeysToBlockExtents) collect: - [:outerPair| - localRefs - detect: [:localPair| outerPair first = localPair first] - ifNone: [{ outerPair first. { #outer. outerPair last } }]]. - outerTemps, - (localRefs reject: [:localPair| outerTemps anySatisfy: [:outerPair| localPair first = outerPair first]])]]! Item was removed: - ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempRefsForMethod:startKeysToBlockExtents: (in category 'private') ----- - privateTempRefsForMethod: method startKeysToBlockExtents: startKeysToBlockExtents - "Answer the sequence of temps in scope in method in the natural order, - outermost arguments and temporaries first, innermost last. Each temp is - a pair of the temp's name followed by a reference. The reference can be - integer - index of temp in aContext - #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index in aContext - #( outer. temp reference ) - a temp reference in an outer context." - blockExtentsToTempRefs ifNil: - [blockExtentsToTempRefs := (method holdsTempNames - ifTrue: [method] - ifFalse: [methodNode]) blockExtentsToTempsMap. - blockExtentsToTempRefs ifNil: - ["an empty method. shouldn't be able to step into here but it - can happen in weird circumstances (i.e. with MethodWrapper)." - blockExtentsToTempRefs := Dictionary new. - blockExtentsToTempRefs - at: (startKeysToBlockExtents at: method startKey) - put: {}]. - startKeysToTempRefs := Dictionary new]. - ^startKeysToTempRefs - at: method startKey - ifAbsentPut: - [blockExtentsToTempRefs at: (startKeysToBlockExtents at: method startKey)]! Item was removed: - DebuggerMethodMapForClosureCompiledMethods subclass: #DebuggerMethodMapForFullBlockCompiledMethods - instanceVariableNames: 'sortedSourceMaps' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !DebuggerMethodMapForFullBlockCompiledMethods commentStamp: 'eem 10/1/2020 19:20' prior: 0! - I am a place-holder for information needed by the Debugger to inspect method activations. See DebuggerMethodMap's comment. I map methods compiled using full block closures, where block methods are objects separate from the home mehtod, as is the case with the SistaV1 bytecode set. - - Instance variables - (inherited) - abstractSourceRanges <Dictionary of: CompiledCode -> (Dictionary of: Integer-> Interval) - startKeysToTempRefs <Dictionary of: CompiledCode -> Array of: (Array with: String with: temp reference)> where - temp reference ::= Integer - | (Array with: Integer with: Integer) - | (Array with: #outer with: temp reference) - (locally defined) - sortedSourceMaps <Dictionary of: CompiledCode -> (Dictionary of: Integer-> Interval)! Item was removed: - ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>abstractSourceMap (in category 'source mapping') ----- - abstractSourceMap - self shouldNotImplement! Item was removed: - ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>abstractSourceMapForMethod: (in category 'source mapping') ----- - abstractSourceMapForMethod: compiledCode - "Answer with a Dictionary of abstractPC <Integer> to sourceRange <Interval> - for compiledCode which may be either a CompiledMethod or a CompiledBlock." - | rawSourceRanges theMethodToScan | - abstractSourceRanges ifNotNil: - [^abstractSourceRanges at: compiledCode]. - abstractSourceRanges := IdentityDictionary new. - "If the methodNode hasn't had a method generated it doesn't have pcs set in its - nodes so we must generate a new method. We use this method for scanning - since its rawSourceRanges refer to the block methods within the method, and - that means we can use identity comparisons to match nodes with blocks." - methodNode rawSourceRangesAndMethodDo: - [:ranges :method| - rawSourceRanges := ranges. - theMethodToScan := method]. - self scanMethod: theMethodToScan mappingRanges: rawSourceRanges. - self mapBlockMethodKeysIn: theMethodToScan toActualBlockMethodsIn: compiledCode homeMethod. - ^abstractSourceRanges at: compiledCode! Item was removed: - ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>mapBlockMethodKeysIn:toActualBlockMethodsIn: (in category 'source mapping') ----- - mapBlockMethodKeysIn: theMethodToScan toActualBlockMethodsIn: actualMethod - abstractSourceRanges at: actualMethod put: (abstractSourceRanges removeKey: theMethodToScan). - 1 to: theMethodToScan numLiterals - 1 do: "i.e. don't scan the last literal which, in CompiledBlocks is a back pointer" - [:i| | lit | - (lit := theMethodToScan literalAt: i) isCompiledCode ifTrue: - [self mapBlockMethodKeysIn: lit toActualBlockMethodsIn: (actualMethod literalAt: i)]]! Item was removed: - ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>newBlockStartMap (in category 'private') ----- - newBlockStartMap - "If blocks are embedded then keys in the map are simple integer pcs and a Dictionary can be used. - If blocks are full (separate method objects) then keys in the map are CompiledBlocks and - IdentityDictionary must be used to avoid confusing blocks with identical code." - ^WeakIdentityKeyDictionary new! Item was removed: - ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>rangeForPC:in:contextIsActiveContext: (in category 'source mapping') ----- - rangeForPC: contextsConcretePC in: method contextIsActiveContext: contextIsActiveContext - "Answer the indices in the source code for the supplied pc. - If the context is the actve context (is at the hot end of the stack) - then its pc is the current pc. But if the context isn't, because it is - suspended sending a message, then its current pc is the previous pc." - - | pc i end mapForMethod sortedMap | - pc := method abstractPCForConcretePC: (contextIsActiveContext - ifTrue: [contextsConcretePC] - ifFalse: [(method pcPreviousTo: contextsConcretePC) - ifNotNil: [:prevpc| prevpc] - ifNil: [contextsConcretePC]]). - ((mapForMethod := self abstractSourceMapForMethod: method) includesKey: pc) ifTrue: - [^mapForMethod at: pc]. - sortedSourceMap ifNil: - [sortedSourceMap := IdentityDictionary new]. - sortedMap := sortedSourceMap - at: method - ifAbsentPut: [mapForMethod associations - replace: [ :each | each copy ]; - sort]. - sortedMap isEmpty ifTrue: [^1 to: 0]. - i := sortedMap findNearbyBinaryIndex: [:assoc| pc - assoc key]. - i < 1 ifTrue: [^1 to: 0]. - i > sortedMap size ifTrue: - [end := sortedMap inject: 0 into: - [:prev :this | prev max: this value last]. - ^end+1 to: end]. - ^(sortedMap at: i) value - - "| method source scanner map | - method := DebuggerMethodMapForFullBlockCompiledMethods compiledMethodAt: #rangeForPC:in:contextIsActiveContext:. - source := method getSourceFromFile asString. - scanner := InstructionStream on: method. - map := method debuggerMap. - Array streamContents: - [:ranges| - [scanner atEnd] whileFalse: - [| range | - range := map rangeForPC: scanner pc in: method contextIsActiveContext: true. - ((map abstractSourceMap includesKey: scanner abstractPC) - and: [range first ~= 0]) ifTrue: - [ranges nextPut: (source copyFrom: range first to: range last)]. - scanner interpretNextInstructionFor: InstructionClient new]]"! Item was removed: - ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>scanMethod:mappingRanges: (in category 'source mapping') ----- - scanMethod: theMethodToScan mappingRanges: rawSourceRanges - | abstractPC scanner client maybeBlock concreteSourceRanges rangesForMethod | - rangesForMethod := (abstractSourceRanges at: theMethodToScan put: Dictionary new). - concreteSourceRanges := Dictionary new. - "The rawSourceRanges map node pcs to ranges. - When node is one in the home method the node's pc is an integer. - When the node is within a block method the node's pc is an association from CompiledBlock to pc. - Extract pc -> range for this particular CompiledMethod or CompiledBlock." - rawSourceRanges keysAndValuesDo: - (theMethodToScan isCompiledMethod - ifTrue: - [[:node :range| - (node pc isVariableBinding - or: [node pc = 0]) ifFalse: - [concreteSourceRanges at: node pc put: range]]] - ifFalse: - [[:node :range| - (node pc isVariableBinding - and: [node pc key == theMethodToScan - and: [node pc value ~= 0]]) ifTrue: - [concreteSourceRanges at: node pc value put: range]]]). - abstractPC := 1. - scanner := InstructionStream on: theMethodToScan. - client := BlockStartLocator new. - [(concreteSourceRanges includesKey: scanner pc) ifTrue: - [rangesForMethod at: abstractPC put: (concreteSourceRanges at: scanner pc)]. - abstractPC := abstractPC + 1. - maybeBlock := scanner interpretNextInstructionFor: client. - (maybeBlock ~~ client - and: [maybeBlock isCompiledCode]) ifTrue: - [self assert: maybeBlock isCompiledBlock. - self scanMethod: maybeBlock mappingRanges: rawSourceRanges]. - scanner atEnd] whileFalse! Item was removed: - CodeHolder subclass: #DependencyBrowser - instanceVariableNames: 'packageList packageDeps packageDepsList classDeps classDepsList classList messageList packageListIndex packageDepsIndex classDepsIndex classListIndex messageListIndex autoSelectString windowTitle' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !DependencyBrowser commentStamp: 'pre 11/29/2021 11:48' prior: 0! - A simple dependency browser showing five panes: - [1]: Packages: The list of available packages in the system. - [2]: Package Dependencies: The packages the currently selected package depends on. - [3]: Class Dependencies: The classes the currently selected package [1] depends on (filtered by the selected required package [2]). - [4]: Class List: The classes in the currently selected package [1] containing the references to the class dependencies [3]. - [5]: Messages: The messages in the currently selected package [1] and class [4] that contain the references to the class dependencies [3]. - - # Implementation - The dependencies are pre-computed whenever the selected package changes [1], see #computePackageAndClassDependencies.! Item was removed: - ----- Method: DependencyBrowser class>>initialize (in category 'class initialization') ----- - initialize - "Initializes the receiver class" - - TheWorldMenu registerOpenCommand: {'Dependency Browser'. {self. #open}}. ! Item was removed: - ----- Method: DependencyBrowser class>>open (in category 'opening') ----- - open - "DependencyBrowser open" - ^ToolBuilder open: self! Item was removed: - ----- Method: DependencyBrowser class>>openInvertedOn: (in category 'opening') ----- - openInvertedOn: requiredPackageNames - "DependencyBrowser openInvertedOn: #(Monticello)" - - | model | - model := self new. - ^ ToolBuilder open: ( - model - packageList: (Cursor wait showWhile: [ - model packageList select: [:packageName | - model computePackageAndClassDependencies: packageName. - model packageDeps includesAnyOf: requiredPackageNames]]); - windowTitle: ('Dependency Browser (inverted on {1})' translated format: {requiredPackageNames}); - yourself) - ! Item was removed: - ----- Method: DependencyBrowser class>>openInvertedOnPackage: (in category 'opening') ----- - openInvertedOnPackage: aPackageInfo - "DependencyBrowser openInvertedOnPackage: Morph packageInfo" - - ^ self openInvertedOn: {aPackageInfo name}! Item was removed: - ----- Method: DependencyBrowser class>>openOn: (in category 'opening') ----- - openOn: packageNames - "DependencyBrowser openOn: #(Morphic EToys)" - - ^ ToolBuilder open: (self new - packageList: packageNames; - windowTitle: 'Dependency Browser (on selected packages)' translated; - yourself)! Item was removed: - ----- Method: DependencyBrowser class>>openOnPackage: (in category 'opening') ----- - openOnPackage: aPackageInfo - "DependencyBrowser openOnPackage: Morph packageInfo" - - ^ ToolBuilder open: (self new - selectPackage: aPackageInfo name; - yourself)! Item was removed: - ----- Method: DependencyBrowser>>aboutToStyle: (in category 'contents') ----- - aboutToStyle: aStyler - "This is a notification that aStyler is about to re-style its text. - Set the classOrMetaClass in aStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - | selectedClass | - selectedClass := self classListSelection ifNil:[^false]. - self messageListSelection ifNil:[^false]. - self isModeStyleable ifFalse: [^ false]. - aStyler classOrMetaClass: ((self messageListSelection == #Definition) ifFalse:[Smalltalk classNamed: selectedClass]). - ^true! Item was removed: - ----- Method: DependencyBrowser>>autoSelectString (in category 'accessing') ----- - autoSelectString - ^ autoSelectString! Item was removed: - ----- Method: DependencyBrowser>>autoSelectString: (in category 'accessing') ----- - autoSelectString: aString - autoSelectString := aString. - self changed: #contentsSelection.! Item was removed: - ----- Method: DependencyBrowser>>buildClassDepsWith: (in category 'toolbuilder') ----- - buildClassDepsWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #classDepsList; - help: 'Required classes' translated; - list: #classDepsList; - getIndex: #classDepsIndex; - setIndex: #classDepsIndex:; - menu: #classDepsMenu:; - keyPress: #classDepsKey:from:. - ^listSpec - ! Item was removed: - ----- Method: DependencyBrowser>>buildClassListWith: (in category 'toolbuilder') ----- - buildClassListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #classList; - help: 'Client classes' translated; - list: #classList; - getIndex: #classListIndex; - setIndex: #classListIndex:; - menu: #classListMenu:; - keyPress: #classListKey:from:. - ^listSpec - ! Item was removed: - ----- Method: DependencyBrowser>>buildMessageListWith: (in category 'toolbuilder') ----- - buildMessageListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #messageList; - help: 'Client methods' translated; - list: #messageList; - getIndex: #messageListIndex; - setIndex: #messageListIndex:; - menu: #messageListMenu:; - keyPress: #messageListKey:from:. - ^listSpec! Item was removed: - ----- Method: DependencyBrowser>>buildPackageDepsWith: (in category 'toolbuilder') ----- - buildPackageDepsWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #packageDepsList; - help: 'Required Packages' translated; - list: #packageDepsList; - getIndex: #packageDepsIndex; - setIndex: #packageDepsIndex:; - menu: #packageDepsMenu:; - keyPress: #packageDepsKey:from:. - ^listSpec - ! Item was removed: - ----- Method: DependencyBrowser>>buildPackageListWith: (in category 'toolbuilder') ----- - buildPackageListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #packageList; - help: 'Packages' translated; - list: #packageList; - getIndex: #packageListIndex; - setIndex: #packageListIndex:; - menu: #packageListMenu:; - keyPress: #packageListKey:from:. - ^listSpec - ! Item was removed: - ----- Method: DependencyBrowser>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "Create the ui for the browser" - | windowSpec max | - max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5]. - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 0.2 at max) -> [self buildPackageListWith: builder]. - (0.2 at 0 corner: 0.4 at max) -> [self buildPackageDepsWith: builder]. - (0.4 at 0 corner: 0.6 at max) -> [self buildClassDepsWith: builder]. - (0.6 at 0 corner: 0.8 at max) -> [self buildClassListWith: builder]. - (0.8 at 0 corner: 1.0 at max) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - ^builder build: windowSpec! Item was removed: - ----- Method: DependencyBrowser>>classDeps (in category 'class dependencies') ----- - classDeps - "Class dependencies for the currently selected package" - packageDeps ifNil: [^ #()]. - ^ (packageDeps at: self packageDepsSelection ifAbsent:[#()]) sort. - ! Item was removed: - ----- Method: DependencyBrowser>>classDepsIndex (in category 'class dependencies') ----- - classDepsIndex - "Class dependency selection" - ^classDepsIndex ifNil:[0]! Item was removed: - ----- Method: DependencyBrowser>>classDepsIndex: (in category 'class dependencies') ----- - classDepsIndex: idx - "Class dependency selection" - classDepsIndex := idx. - self changed: #classDepsIndex. - classList := nil. - self changed: #classList. - self classListIndex: (idx = 0 ifTrue: [0] ifFalse: [1]).! Item was removed: - ----- Method: DependencyBrowser>>classDepsKey:from: (in category 'class dependencies') ----- - classDepsKey: aCharacter from: aPluggableListMorphPlus - aCharacter = $N ifTrue: [^ self referencesToIt: (self classDeps at: self classDepsIndex)].! Item was removed: - ----- Method: DependencyBrowser>>classDepsList (in category 'class dependencies') ----- - classDepsList - "Class dependencies for the currently selected package" - - | checkDef checkExt | - checkDef := [:mref | mref selector = #Definition]. - checkExt := [:mref | mref category notNil and: [mref category first = $*]]. - - ^ classDepsList ifNil: [ - classDepsList := self classDeps. - classDepsList := classDepsList collect: [:className | - String streamContents: [:label | - label nextPutAll: className. - (self depsForClassNamed: className allSatisfy: checkDef) - ifTrue: [label nextPutAll: ' (defs only)' translated] - ifFalse: [(self depsForClassNamed: className allSatisfy: checkExt) - ifTrue: [label nextPutAll: ' *exts only' translated] - ifFalse: [ - (self depsForClassNamed: className anySatisfy: checkDef) - ifTrue: [label nextPutAll: ' ()']. - (self depsForClassNamed: className anySatisfy: checkExt) - ifTrue: [label nextPutAll: ' *']]]]]]! Item was removed: - ----- Method: DependencyBrowser>>classDepsMenu: (in category 'class dependencies') ----- - classDepsMenu: aMenu - ^aMenu! Item was removed: - ----- Method: DependencyBrowser>>classDepsSelection (in category 'class dependencies') ----- - classDepsSelection - "Class dependency selection" - ^(self classDepsIndex between: 1 and: self classDeps size) - ifTrue:[self classDeps at: self classDepsIndex].! Item was removed: - ----- Method: DependencyBrowser>>classList (in category 'class list') ----- - classList - "List of classes that refer to dependencies" - | selectedPackage | - classDeps ifNil: [^ #()]. - self classDepsSelection ifNil: [^ #()]. - - selectedPackage := PackageOrganizer default - packageNamed: self packageListSelection ifAbsent: [nil]. - - classList := (classDeps at: self classDepsSelection ifAbsent: [#()]) - collect: [:mref | - mref selector = #Definition - ifTrue: [mref actualClass name, ' (class definition)' translated] - ifFalse: [mref category first = $* - ifTrue: ['*extensions' translated] - ifFalse: [mref actualClass name]]] - as: Set. - - ^ classList := classList asArray sort! Item was removed: - ----- Method: DependencyBrowser>>classListIndex (in category 'class list') ----- - classListIndex - "Class list selection" - ^classListIndex ifNil:[0]! Item was removed: - ----- Method: DependencyBrowser>>classListIndex: (in category 'class list') ----- - classListIndex: idx - "Class list selection" - classListIndex := idx. - self changed: #classListIndex. - self changed: #messageList. - self messageListIndex: (idx = 0 ifTrue: [0] ifFalse: [1]). - ! Item was removed: - ----- Method: DependencyBrowser>>classListMenu: (in category 'class list') ----- - classListMenu: aMenu - ^aMenu! Item was removed: - ----- Method: DependencyBrowser>>classListSelection (in category 'class list') ----- - classListSelection - "Class list selection" - ^ self selectedClassOrMetaClass name! Item was removed: - ----- Method: DependencyBrowser>>computeClassDependenciesFor: (in category 'private - dependencies') ----- - computeClassDependenciesFor: packageInfo - - packageInfo classes do: [:pkgClass | - "Add the superclass and SharedPools as dependencies." - (classDeps at: (pkgClass superclass ifNil: [ProtoObject]) name - ifAbsentPut: [OrderedCollection new]) add: - (MethodReference class: pkgClass selector: #Definition). - pkgClass sharedPools do: [:sharedPool | - sharedPool isBehavior ifTrue: [ - (classDeps at: sharedPool name - ifAbsentPut: [OrderedCollection new]) add: - (MethodReference class: pkgClass selector: #Definition)]]]. - - packageInfo coreMethods do: [:mref | - mref compiledMethod allLiteralsDo: [:lit | - (lit isVariableBinding and: [lit value isBehavior]) ifTrue: [ - (classDeps at: lit value name ifAbsentPut: [OrderedCollection new]) - add: mref]]]. - - packageInfo extensionMethods do: [:mref | - (classDeps at: mref actualClass name ifAbsentPut: [OrderedCollection new]) - add: mref]. - ! Item was removed: - ----- Method: DependencyBrowser>>computePackageAndClassDependencies: (in category 'private - dependencies') ----- - computePackageAndClassDependencies: pkgName - "Compute the dependencies for the given package" - | packageInfo | - classDeps := Dictionary new. - packageDeps := Dictionary new. - pkgName ifNil: [^ self]. - packageInfo := PackageOrganizer default - packageNamed: pkgName - ifAbsent:["unloaded" ^ self]. - - self - computeClassDependenciesFor: packageInfo; - computePackageDependencies. - - (packageDeps removeKey: pkgName ifAbsent: [#()]) do: [:each | - classDeps removeKey: each ifAbsent: []].! Item was removed: - ----- Method: DependencyBrowser>>computePackageDependencies (in category 'private - dependencies') ----- - computePackageDependencies - - classDeps keys do:[:className| | aClass pkg | - aClass := Smalltalk classNamed: className. - pkg := aClass ifNil: [nil] ifNotNil: [PackageOrganizer default packageOfClass: aClass ifNone:[nil]]. - pkg - ifNil:[ - Transcript cr; show: 'WARNING: No package for ', className. - (classDeps removeKey: className) do:[:each| Transcript crtab; show: each]] - ifNotNil:[ - (packageDeps at: pkg name ifAbsentPut:[OrderedCollection new]) add: className]].! Item was removed: - ----- Method: DependencyBrowser>>contents:notifying: (in category 'contents') ----- - contents: input notifying: aController - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment, - hierarchy). Answer the result of updating the source." - - | aString aText theClass theMethodName | - self changed: #annotation. - aString := input asString. - aText := input asText. - - theClass := self selectedClassOrMetaClass. - theMethodName := self selectedMessageName. - (theClass notNil and: [theMethodName notNil]) ifTrue: [ - ^ self okayToAccept - ifFalse: - [false] - ifTrue: - [self defineMessageFrom: aText notifying: aController]]. - self error: 'unacceptable accept' translated! Item was removed: - ----- Method: DependencyBrowser>>contentsSelection (in category 'accessing') ----- - contentsSelection - - ^ self autoSelectString - ifNil: [super contentsSelection] - ifNotNil: [:term | | index | - (index := self contents asString findString: term) > 0 - ifTrue: [index to: index + term size - 1] - ifFalse: [super contentsSelection]]! Item was removed: - ----- Method: DependencyBrowser>>defineMessageFrom:notifying: (in category 'contents') ----- - defineMessageFrom: aString notifying: aController - "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." - | selectedMessageName selector category oldMessageList | - selectedMessageName := self selectedMessageName. - oldMessageList := self messageList. - contents := nil. - selector := (self selectedClassOrMetaClass newParser parseSelector: aString). - selector := self selectedClassOrMetaClass - compile: aString - classified: (category := self selectedMessageCategoryName) - notifying: aController. - selector == nil ifTrue: [^ false]. - contents := aString copy. - ^ true - ! Item was removed: - ----- Method: DependencyBrowser>>depsForClassNamed:allSatisfy: (in category 'enumerating') ----- - depsForClassNamed: className allSatisfy: workBlock - - self - depsForClassNamed: className - do: [:mref | (workBlock value: mref) ifFalse: [^ false]]. - ^ true! Item was removed: - ----- Method: DependencyBrowser>>depsForClassNamed:anySatisfy: (in category 'enumerating') ----- - depsForClassNamed: className anySatisfy: workBlock - - self - depsForClassNamed: className - do: [:mref | (workBlock value: mref) ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: DependencyBrowser>>depsForClassNamed:do: (in category 'enumerating') ----- - depsForClassNamed: className do: workBlock - - classDeps ifNil: [^ self]. - (classDeps at: className ifAbsent: [^ self]) do: workBlock.! Item was removed: - ----- Method: DependencyBrowser>>depsForPackageNamed:allSatisfy: (in category 'enumerating') ----- - depsForPackageNamed: packageName allSatisfy: workBlock - - self - depsForPackageNamed: packageName - do: [:mref | (workBlock value: mref) ifFalse: [^ false]]. - ^ true! Item was removed: - ----- Method: DependencyBrowser>>depsForPackageNamed:anySatisfy: (in category 'enumerating') ----- - depsForPackageNamed: packageName anySatisfy: workBlock - - self - depsForPackageNamed: packageName - do: [:mref | (workBlock value: mref) ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: DependencyBrowser>>depsForPackageNamed:do: (in category 'enumerating') ----- - depsForPackageNamed: packageName do: workBlock - - packageDeps ifNil: [^ self]. - (packageDeps at: packageName) do: [:className | - self - depsForClassNamed: className - do: workBlock]! Item was removed: - ----- Method: DependencyBrowser>>hasPackageSelected (in category 'package list') ----- - hasPackageSelected - ^ packageListIndex > 0.! Item was removed: - ----- Method: DependencyBrowser>>initialize (in category 'initialize-release') ----- - initialize - super initialize. - packageListIndex := 0. - packageDepsIndex := 0. - classDepsIndex := 0. - classListIndex := 0. - messageListIndex := 0.! Item was removed: - ----- Method: DependencyBrowser>>messageList (in category 'message list') ----- - messageList - "List of messages creating dependencies" - | selectedClass label filter | - classDeps ifNil: [^ #()]. - classList ifNil: [^ #()]. - - selectedClass := self classListSelection. - label := classList at: classListIndex ifAbsent: ['']. - - filter := label ifEmpty: [ [:mref | false] ] ifNotEmpty: [ - (label first = $* or: [(label endsWith: '(class definition)' translated) not]) - ifTrue: [ [:mref | mref selector ~= #Definition and: [mref actualClass name = selectedClass]] ] - ifFalse: [ [:mref | mref selector = #Definition and: [mref actualClass name = selectedClass]] ]]. - - ^((classDeps at: self classDepsSelection ifAbsent:[#()]) - select: filter - thenCollect:[:mref| mref methodSymbol]) asSet asArray sort! Item was removed: - ----- Method: DependencyBrowser>>messageListIndex (in category 'message list') ----- - messageListIndex - "Message list selection" - ^messageListIndex ifNil:[0]! Item was removed: - ----- Method: DependencyBrowser>>messageListIndex: (in category 'message list') ----- - messageListIndex: idx - "Message list selection" - messageListIndex := idx. - self changed: #messageListIndex. - self changed: #contents. - self changed: #annotation. - - self autoSelectString: self classDepsSelection.! Item was removed: - ----- Method: DependencyBrowser>>messageListMenu: (in category 'message list') ----- - messageListMenu: aMenu - ^aMenu! Item was removed: - ----- Method: DependencyBrowser>>messageListSelection (in category 'message list') ----- - messageListSelection - "Message list selection" - ^(self messageListIndex between: 1 and: self messageList size) - ifTrue:[self messageList at: self messageListIndex]! Item was removed: - ----- Method: DependencyBrowser>>packageDeps (in category 'package dependencies') ----- - packageDeps - "Package dependencies for the currently selected package" - packageDeps ifNil:[ - packageDeps := Dictionary new. - Cursor wait showWhile:[ - self computePackageAndClassDependencies: self packageListSelection. - ]. - ]. - ^packageDeps keys sort! Item was removed: - ----- Method: DependencyBrowser>>packageDepsIndex (in category 'package dependencies') ----- - packageDepsIndex - "Current package dependencies selection" - ^packageDepsIndex ifNil:[0]! Item was removed: - ----- Method: DependencyBrowser>>packageDepsIndex: (in category 'package dependencies') ----- - packageDepsIndex: aNumber - "Current package dependencies selection" - packageDepsIndex := aNumber. - self changed: #packageDepsIndex. - - classDepsList := nil. - self changed: #classDepsList. - self classDepsIndex: (aNumber = 0 ifTrue: [0] ifFalse: [1]). - ! Item was removed: - ----- Method: DependencyBrowser>>packageDepsList (in category 'package dependencies') ----- - packageDepsList - "Package dependencies for the currently selected package" - - | checkDef checkExt | - checkDef := [:mref | mref selector = #Definition]. - checkExt := [:mref | mref category notNil and: [mref category first = $*]]. - - ^ packageDepsList ifNil: [ - packageDepsList := self packageDeps. - packageDepsList := packageDepsList collect: [:packageName | - String streamContents: [:label | - label nextPutAll: packageName. - (self depsForPackageNamed: packageName allSatisfy: checkDef) - ifTrue: [label nextPutAll: ' (defs only)' translated] - ifFalse: [(self depsForPackageNamed: packageName allSatisfy: checkExt) - ifTrue: [label nextPutAll: ' *exts only' translated] - ifFalse: [ - (self depsForPackageNamed: packageName anySatisfy: checkDef) - ifTrue: [label nextPutAll: ' ()']. - (self depsForPackageNamed: packageName anySatisfy: checkExt) - ifTrue: [label nextPutAll: ' *']]]]]]! Item was removed: - ----- Method: DependencyBrowser>>packageDepsMenu: (in category 'package dependencies') ----- - packageDepsMenu: aMenu - ^aMenu! Item was removed: - ----- Method: DependencyBrowser>>packageDepsSelection (in category 'package dependencies') ----- - packageDepsSelection - "Current package dependencies selection" - ^(self packageDepsIndex between: 1 and: self packageDeps size) - ifTrue:[self packageDeps at: self packageDepsIndex]! Item was removed: - ----- Method: DependencyBrowser>>packageList (in category 'package list') ----- - packageList - "The base list of packages in the system" - ^packageList ifNil:[packageList := (PackageInfo allPackages collect: [ :each | each packageName]) sort]! Item was removed: - ----- Method: DependencyBrowser>>packageList: (in category 'package list') ----- - packageList: somePackageNames - - packageList := somePackageNames. - self packageListIndex: 0.! Item was removed: - ----- Method: DependencyBrowser>>packageListIndex (in category 'package list') ----- - packageListIndex - "Current package list selection" - ^packageListIndex ifNil:[0]! Item was removed: - ----- Method: DependencyBrowser>>packageListIndex: (in category 'package list') ----- - packageListIndex: aNumber - "Current package list selection" - packageListIndex := aNumber. - self changed: #packageListIndex. - packageDeps := nil. - packageDepsList := nil. - self changed: #packageDepsList. - self packageDepsIndex: (aNumber = 0 ifTrue: [0] ifFalse: [1]). - ! Item was removed: - ----- Method: DependencyBrowser>>packageListKey:from: (in category 'package list') ----- - packageListKey: aChar from: view - aChar == $f ifTrue: [^ self findClass]. - ^ self classListKey: aChar from: view! Item was removed: - ----- Method: DependencyBrowser>>packageListMenu: (in category 'package list') ----- - packageListMenu: aMenu - ^aMenu! Item was removed: - ----- Method: DependencyBrowser>>packageListSelection (in category 'package list') ----- - packageListSelection - "Current package list selection" - ^(self packageListIndex between: 1 and: self packageList size) - ifTrue:[self packageList at: self packageListIndex]! Item was removed: - ----- Method: DependencyBrowser>>referencesToIt: (in category 'accessing') ----- - referencesToIt: aClassName - | binding environment | - environment := self selectedEnvironment. - binding := (environment bindingOf: aClassName) ifNil: [ ^ self ]. - self systemNavigation browseAllCallsOn: binding! Item was removed: - ----- Method: DependencyBrowser>>representsSameBrowseeAs: (in category 'morphic ui') ----- - representsSameBrowseeAs: anotherModel - ^ self hasUnacceptedEdits not! Item was removed: - ----- Method: DependencyBrowser>>selectPackage: (in category 'class list') ----- - selectPackage: packageName - - self packageListIndex: (self packageList indexOf: packageName).! Item was removed: - ----- Method: DependencyBrowser>>selectedClass (in category 'class list') ----- - selectedClass - "Answer the class that is currently selected. Answer nil if no selection exists." - - ^ self selectedClassOrMetaClass - ! Item was removed: - ----- Method: DependencyBrowser>>selectedClassName (in category 'class list') ----- - selectedClassName - | idx | - idx := classListIndex ifNil: [0]. - ^ (classList ifNotNil: [ :l | l at: idx ifAbsent: [nil]]) - ifNotNil: [:label | - label first = $* - ifTrue: [nil "extension methods"] - ifFalse: [(label endsWith: '(class definition)' translated) - ifTrue: [label findTokens first] - ifFalse: [label "e.g., 'String' or 'String class'"]]]! Item was removed: - ----- Method: DependencyBrowser>>selectedClassOrMetaClass (in category 'class list') ----- - selectedClassOrMetaClass - "Answer the class or metaclass that is currently selected. Answer nil if no selection - exists." - classList ifNil: [^nil]. - ^ (self selectedEnvironment classNamed: (self selectedClassName ifNil: [''])) - ifNil: [classListIndex > 0 ifFalse: [nil] ifTrue: [ - "Use the class the current selection is depending on such as for method extensions or (base) class definitions." - self selectedEnvironment classNamed: (self classDepsSelection ifNil: [''])]]! Item was removed: - ----- Method: DependencyBrowser>>selectedEnvironment (in category 'accessing') ----- - selectedEnvironment - "Answer the name of the selected package or nil." - - self hasPackageSelected ifFalse: [^nil]. - ^ Smalltalk globals! Item was removed: - ----- Method: DependencyBrowser>>selectedMessage (in category 'contents') ----- - selectedMessage - "Source code for currently selected message" - | className methodName mref | - className := self classListSelection. - methodName := self messageListSelection. - mref := (classDeps at: self classDepsSelection ifAbsent:[#()]) - detect:[:mr| mr actualClass name = className - and:[mr methodSymbol = methodName]] - ifNone:[nil]. - mref ifNil:[^ self class comment]. - mref methodSymbol == #Definition ifTrue:[^ mref actualClass definition]. - ^mref sourceCode! Item was removed: - ----- Method: DependencyBrowser>>selectedMessageName (in category 'message list') ----- - selectedMessageName - ^ self messageList at: messageListIndex ifAbsent: [nil]! Item was removed: - ----- Method: DependencyBrowser>>selectedPackage (in category 'package list') ----- - selectedPackage - - ^ self environment packageOrganizer - packageNamed: self selectedPackageName - ifAbsent: [nil]! Item was removed: - ----- Method: DependencyBrowser>>selectedPackageName (in category 'package list') ----- - selectedPackageName - - ^ self hasPackageSelected - ifFalse: [nil] - ifTrue: [self packageList at: packageListIndex]! Item was removed: - ----- Method: DependencyBrowser>>windowTitle (in category 'accessing') ----- - windowTitle - - ^ windowTitle ifNil: ['Dependency Browser']! Item was removed: - ----- Method: DependencyBrowser>>windowTitle: (in category 'accessing') ----- - windowTitle: aString - - windowTitle := aString. - self changed: #windowTitle.! Item was removed: - ----- Method: Dictionary>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^ DictionaryInspector! Item was removed: - CollectionInspector subclass: #DictionaryInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !DictionaryInspector commentStamp: 'ct 1/12/2020 15:26' prior: 0! - I am an Inspector that is specialized for inspecting Dictionarys.! Item was removed: - ----- Method: DictionaryInspector>>addElement (in category 'menu - commands') ----- - addElement - - self addElement: (self requestKeyOrCancel: [^ self]).! Item was removed: - ----- Method: DictionaryInspector>>addElement: (in category 'menu - commands') ----- - addElement: aKey - - self object at: aKey put: nil. - self updateFields. - - self selectKey: aKey. - self hasSelection ifFalse: [self inform: ('The new key {1} was added.\\Yet, the list of fields is quite long. The new field\got truncated and is thus not visible.' translated withCRs format: {aKey printString})].! Item was removed: - ----- Method: DictionaryInspector>>addFieldItemsTo: (in category 'menu - construction') ----- - addFieldItemsTo: aMenu - - super addFieldItemsTo: aMenu. - - self typeOfSelection = #element ifFalse: [^ self]. - - aMenu addLine. - - self selectedKey isSymbol ifTrue: [ - aMenu addTranslatedList: #( - ('senders of this key' sendersOfSelectedKey))]. - - aMenu addTranslatedList: #( - ('inspect key' inspectKey) - ('rename key' renameKey)). - - self isBindingSelected ifTrue: [ - aMenu addTranslatedList: #( - - - ('references to binding' usersOfSelectedBinding 'Browse all users of this binding.'))].! Item was removed: - ----- Method: DictionaryInspector>>canAddOrRemoveElements (in category 'private') ----- - canAddOrRemoveElements - "Due to a strange reason, #add: is supported in Dictionary but #remove:ifAbsent: is not." - - ^ true! Item was removed: - ----- Method: DictionaryInspector>>elementIndices (in category 'private') ----- - elementIndices - - ^ [ self object keysInOrder ] ifError: [ - "Can occur when debugging Dictionary new" - Array empty]! Item was removed: - ----- Method: DictionaryInspector>>inspectKey (in category 'menu - commands') ----- - inspectKey - "Create and schedule an Inspector on the receiver's model's currently selected key." - - self assertElementSelectedOr: [^ self]. - self selectedKey inspect.! Item was removed: - ----- Method: DictionaryInspector>>isBindingSelected (in category 'bindings') ----- - isBindingSelected - "Whether the currently selection association is a binding to a class or global." - - ^ self selectedKey ifNil: [false] ifNotNil: [:key | - (self object associationAt: key) isVariableBinding]! Item was removed: - ----- Method: DictionaryInspector>>removeSelectedElement (in category 'menu - commands') ----- - removeSelectedElement - - self object removeKey: self selectedKey.! Item was removed: - ----- Method: DictionaryInspector>>renameKey (in category 'menu - commands') ----- - renameKey - - self assertElementSelectedOr: [^ self changed: #flash]. - self renameKey: ( - self - requestKeyInitialAnswer: self selectedKey storeString - orCancel: [^ self]).! Item was removed: - ----- Method: DictionaryInspector>>renameKey: (in category 'menu - commands') ----- - renameKey: aKey - - self assertElementSelectedOr: [^ self changed: #flash]. - - (self object includesKey: aKey) - ifTrue: [(self confirm: 'The target key exists. Do you want to replace it?' translated) - ifFalse: [^ self]]. - - self object - at: aKey put: self selection; - removeKey: self selectedKey. - self updateFields. - - self selectKey: aKey. - self hasSelection ifFalse: [self inform: ('The selected key was renamed to {1}.\\Yet, the list of fields is quite long. The new field\got truncated and is thus not visible.' translated withCRs format: {aKey printString})].! Item was removed: - ----- Method: DictionaryInspector>>requestKeyInitialAnswer:orCancel: (in category 'ui requests') ----- - requestKeyInitialAnswer: anAnswerString orCancel: aBlock - - ^ self - requestObject: ('Enter an expression for the new key\such as #tree, ''apple'', and 3+4.' translated withCRs) - initialAnswer: anAnswerString - orCancel: aBlock! Item was removed: - ----- Method: DictionaryInspector>>requestKeyOrCancel: (in category 'ui requests') ----- - requestKeyOrCancel: aBlock - - ^ self - requestKeyInitialAnswer: String empty - orCancel: aBlock! Item was removed: - ----- Method: DictionaryInspector>>selectKey: (in category 'selection') ----- - selectKey: aKey - "Overriden to make clear that a dictionary's indices are called 'keys'." - - self selectElementAt: aKey.! Item was removed: - ----- Method: DictionaryInspector>>selectedBinding (in category 'bindings') ----- - selectedBinding - - ^ self selectedKey - ifNotNil: [:key | self object associationAt: key]! Item was removed: - ----- Method: DictionaryInspector>>selectedKey (in category 'selection') ----- - selectedKey - "Overriden to make clear that a dictionary's indices are called 'keys'." - - ^ self selectedElementIndex! Item was removed: - ----- Method: DictionaryInspector>>sendersOfSelectedKey (in category 'menu - commands') ----- - sendersOfSelectedKey - "Create a browser on all senders of the selected key" - - | aKey | - ((aKey := self selectedKey) isSymbol) - ifFalse: [^ self changed: #flash]. - self systemNavigation browseAllCallsOn: aKey! Item was removed: - ----- Method: DictionaryInspector>>usersOfSelectedBinding (in category 'menu - commands') ----- - usersOfSelectedBinding - "Create a browser on all references to the association of the current selection." - - self selectedBinding ifNotNil: [:binding | - self systemNavigation browseAllCallsOn: binding].! Item was removed: - Model subclass: #DualChangeSorter - instanceVariableNames: 'leftCngSorter rightCngSorter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - - !DualChangeSorter commentStamp: '<historical>' prior: 0! - This class presents a view of a two change sets at once, and supports copying changes between change sets. - ! Item was removed: - ----- Method: DualChangeSorter class>>open (in category 'opening') ----- - open - "Open a new instance of the receiver's class" - - self new open! Item was removed: - ----- Method: DualChangeSorter class>>prototypicalToolWindow (in category 'opening') ----- - prototypicalToolWindow - "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" - - ^ ToolBuilder build: self new! Item was removed: - ----- Method: DualChangeSorter class>>registerInFlapsRegistry (in category 'class initialization') ----- - registerInFlapsRegistry - "Register the receiver in the system's flaps registry" - self environment - at: #Flaps - ifPresent: [:cl | cl registerQuad: {#DualChangeSorter, #prototypicalToolWindow. 'Change Sorter' translatedNoop. 'Shows two change sets side by side' translatedNoop} - forFlapNamed: 'Tools']! Item was removed: - ----- Method: DualChangeSorter class>>unload (in category 'class initialization') ----- - unload - "Unload the receiver from global registries" - - self environment at: #Flaps ifPresent: [:cl | - cl unregisterQuadsWithReceiver: self] ! Item was removed: - ----- Method: DualChangeSorter>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - | windowSpec window | - leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current. - leftCngSorter parent: self. - rightCngSorter := ChangeSorter new myChangeSet: - ChangeSet secondaryChangeSet. - rightCngSorter parent: self. - - windowSpec := self buildWindowWith: builder. - leftCngSorter buildWith: builder in: windowSpec rect: (0 at 0 extent: 0.5 at 1). - rightCngSorter buildWith: builder in: windowSpec rect: (0.5 at 0 extent: 0.5 at 1). - window := builder build: windowSpec. - leftCngSorter addDependent: window. "so it will get changed: #relabel" - rightCngSorter addDependent: window. "so it will get changed: #relabel" - ^window! Item was removed: - ----- Method: DualChangeSorter>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.719 g: 0.9 b: 0.9)! Item was removed: - ----- Method: DualChangeSorter>>isLeftSide: (in category 'other') ----- - isLeftSide: theOne - "Which side am I?" - ^ theOne == leftCngSorter! Item was removed: - ----- Method: DualChangeSorter>>labelString (in category 'other') ----- - labelString - - ^ 'Changes go to "{1}"' translated format: {ChangeSet current name}! Item was removed: - ----- Method: DualChangeSorter>>modelWakeUp (in category 'other') ----- - modelWakeUp - "A window with me as model is being entered. Make sure I am up-to-date with the changeSets." - - "Dumb way" - leftCngSorter canDiscardEdits - ifTrue: [leftCngSorter update] "does both" - ifFalse: [rightCngSorter update]. - ! Item was removed: - ----- Method: DualChangeSorter>>okToChange (in category 'initialization') ----- - okToChange - ^ leftCngSorter okToChange & rightCngSorter okToChange! Item was removed: - ----- Method: DualChangeSorter>>open (in category 'initialization') ----- - open - ^ToolBuilder open: self! Item was removed: - ----- Method: DualChangeSorter>>other: (in category 'other') ----- - other: theOne - "Return the other side's ChangeSorter" - ^ theOne == leftCngSorter - ifTrue: [rightCngSorter] - ifFalse: [leftCngSorter]! Item was removed: - ----- Method: DualChangeSorter>>release (in category 'initialization') ----- - release - leftCngSorter release. - rightCngSorter release.! Item was removed: - SelectionMenu subclass: #EmphasizedMenu - instanceVariableNames: 'emphases' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - - !EmphasizedMenu commentStamp: '<historical>' prior: 0! - A selection menu in which individual selections are allowed to have different emphases. Emphases allowed are: bold, italic, struckThrough, and plain. Provide an emphasis array, with one element per selection, to use. Refer to the class method #example.! Item was removed: - ----- Method: EmphasizedMenu class>>example1 (in category 'examples') ----- - example1 - "EmphasizedMenu example1" - - ^ (self - selections: #('how' 'well' 'does' 'this' 'work?' ) - emphases: #(#bold #normal #italic #struckOut #normal )) - startUpWithCaption: 'A Menu with Emphases'! Item was removed: - ----- Method: EmphasizedMenu class>>example2 (in category 'examples') ----- - example2 - "EmphasizedMenu example2" - - | aMenu | - aMenu := EmphasizedMenu selections: #('One' 'Two' 'Three' 'Four'). - aMenu onlyBoldItem: 3. - ^ aMenu startUpWithCaption: 'Only the Bold'! Item was removed: - ----- Method: EmphasizedMenu class>>example3 (in category 'examples') ----- - example3 - "EmphasizedMenu example3" - - ^ (self - selectionAndEmphasisPairs: #('how' #bold 'well' #normal 'does' #italic 'this' #struckOut 'work' #normal)) - startUpWithCaption: 'A Menu with Emphases'! Item was removed: - ----- Method: EmphasizedMenu class>>selectionAndEmphasisPairs: (in category 'instance creation') ----- - selectionAndEmphasisPairs: interleavedList - "An alternative form of call. " - | selList emphList | - selList := OrderedCollection new. - emphList := OrderedCollection new. - interleavedList pairsDo: - [:aSel :anEmph | - selList add: aSel. - emphList add: anEmph]. - ^ self selections:selList emphases: emphList! Item was removed: - ----- Method: EmphasizedMenu class>>selections:emphases: (in category 'instance creation') ----- - selections: selList emphases: emphList - "Answer an instance of the receiver with the given selections and - emphases." - - ^ (self selections: selList) emphases: emphList - - "Example: - (EmphasizedMenu - selections: #('how' 'well' 'does' 'this' 'work?') - emphases: #(bold plain italic struckOut plain)) startUp"! Item was removed: - ----- Method: EmphasizedMenu>>emphases: (in category 'emphasis') ----- - emphases: emphasisArray - emphases := emphasisArray! Item was removed: - ----- Method: EmphasizedMenu>>onlyBoldItem: (in category 'emphasis') ----- - onlyBoldItem: itemNumber - "Set up emphasis such that all items are plain except for the given item number. " - - emphases := (Array new: selections size) atAllPut: #normal. - emphases at: itemNumber put: #bold! Item was removed: - ----- Method: EmphasizedMenu>>setEmphasis (in category 'private') ----- - setEmphasis - "Set up the receiver to reflect the emphases in the emphases array. " - - | selStart selEnd currEmphasis | - - labelString := labelString asText. - emphases isEmptyOrNil ifTrue: [^ self]. - selStart := 1. - 1 to: selections size do: - [:line | - selEnd := selStart + (selections at: line) size - 1. - ((currEmphasis := emphases at: line) size > 0 and: [currEmphasis ~~ #normal]) ifTrue: - [labelString addAttribute: (TextEmphasis perform: currEmphasis) - from: selStart to: selEnd]. - selStart := selEnd + 2]! Item was removed: - ----- Method: EmphasizedMenu>>startUpWithCaption: (in category 'display') ----- - startUpWithCaption: captionOrNil - self setEmphasis. - ^ super startUpWithCaption: captionOrNil! Item was removed: - ----- Method: EncodedCharSet class>>browseAllCodePoints (in category '*Tools-Browsing') ----- - browseAllCodePoints - " - JISX0208 browseAllCodePoints. - GB2312 browseAllCodePoints. - KSX1001 browseAllCodePoints. - " - - self browseAllCodePointsUsing: TextStyle defaultFont.! Item was removed: - ----- Method: EncodedCharSet class>>browseAllCodePointsUsing: (in category '*Tools-Browsing') ----- - browseAllCodePointsUsing: aFont - "Apply the receivers encoding to browse the result using glyphs of aFont (and its #fallbackFont). - - (Locale isoLanguage: 'ja') languageEnvironment installFont. --- Fetch StrikeFont from metatoys.org; see #fontDownloadUrls - JISX0208 browseAllCodePointsUsing: (TextConstants at: #FontJapaneseEnvironment) last. --- Largest point size - ... - JISX0208 browseAllCodePointsUsing: (TTFontFileHandle fromFontFileName: 'C:\Windows\Fonts\msgothic.ttc') first font. - GB2312 browseAllCodePointsUsing: (TTFontFileHandle fromFontFileName: 'C:\Windows\Fonts\msyh.ttc') first font. - KSX1001 browseAllCodePointsUsing: (TTFontFileHandle fromFontFileName: 'C:\Windows\Fonts\batang.ttc') first font. - " - - aFont - browseGlyphsOf: (Array streamContents: [:s | | last | - self ucsTable do: [:ea | - (ea = -1 and: [last ~= -1] and: [s position > 0]) - ifTrue: [s cr; cr] ifFalse: [ea ~= -1 ifTrue: [s nextPut: ea]]. - last := ea]]) - label: self name, ' encoding'.! Item was removed: - ----- Method: Environment>>browse (in category '*Tools-Browsing') ----- - browse - - ^ ToolSet browseEnvironment: self! Item was removed: - ----- Method: Exception class>>toolIcon (in category '*Tools-icons') ----- - toolIcon - - ^ #exception! Item was removed: - FileList2 subclass: #FileChooser - instanceVariableNames: 'view caption captionMorph captionBox cancelButton okButton buttonPane captionPane directoryPane filePane showShortFileNames' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - - !FileChooser commentStamp: 'miki 8/15/2005 12:07' prior: 0! - This class provides a simple "modal" dialog box to choose a file, with a directory tree, a file list, and open and cancel buttons. It is meant to be an improvement of FileList2 modalFileSelector. - - An applictaion can customize the user interface in a straightforward way. Creation of the file choser is done in several steps by calling various helper methods.. - - The order of the method calls when creating a customized file chooser are important. The UI must be created before methods that change the attributes of the UI can be called. You can either start by creating the default UI, and them modify the morphs in the file chooser (there are methods to access the buttons and the panes). - - You can also build a completely custom UI, by writing your own methods for creating the layout etc. One way to do this is to subclass FileChooser and override the methods you want to change, andother way is to supply your own morphic view to the file chooser. This must be an instance of MorphicModel or a subclass of it, because the file chooser uses the model functionality. - - There are two varieties of the UI, one that is supposed to be like a dialog box (uses colors from the menu preferences in class Preference), and one is using a system window. The way a system window works turns out to be somehat different from how a plain Morphic Model works, and this is why there are separate methods for creating the dialog box UI and the system window UI. - - On the class side, there are examples that shows differents ways to use this class. - - On the to do list is adding support for a file save dialog box, with a directory tree and a text input field for typing a file name. - - (Mikael Kindborg, 050815) - ! Item was removed: - ----- Method: FileChooser class>>example1 (in category 'examples') ----- - example1 - "Open file chooser with the standard dialog box UI." - "FileChooser example1" - | fc stream | - fc := FileChooser new. - fc initializeAsDialogBox. - stream := fc open. - stream inspect.! Item was removed: - ----- Method: FileChooser class>>example2 (in category 'examples') ----- - example2 - "Open file chooser with a system window UI." - "FileChooser example2" - | fc stream | - fc := FileChooser new. - fc initializeAsSystemWindow. - stream := fc open. - stream inspect.! Item was removed: - ----- Method: FileChooser class>>example3 (in category 'examples') ----- - example3 - "Open file chooser with a system window UI that has a caption pane and shows only picture files." - "FileChooser example3" - | fc stream | - fc := FileChooser new. - fc initializeAsSystemWindowWithCaptionPane. - fc setCaption: 'Select a picture file' translated. - fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }. - stream := fc open. - stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].! Item was removed: - ----- Method: FileChooser class>>example4 (in category 'examples') ----- - example4 - "Open file chooser with a customized dialog box UI. The order of the messages is important. In general, call the initialize method first, then modify things, and finally call open." - "FileChooser example4" - | fc stream | - fc := FileChooser new. - fc initializeAsDialogBox. - fc setDirectory: FileDirectory root. - fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }. - fc setCaption: 'Select a picture file' translated. - fc morphicView - borderColor: Color black; - borderWidth: 2; - color: Color white. - fc setPaneColor: Color gray muchLighter. - fc captionPane color: Color orange muchLighter. - fc okButton color: Color green muchLighter. - fc cancelButton color: Color blue muchLighter. - fc morphicView position: 20 at 20. - stream := fc open. - stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].! Item was removed: - ----- Method: FileChooser class>>new (in category 'instance creation') ----- - new - "Superclass may attempt to initialize to a specific default directory. Bypass - that behavior." - - ^ self basicNew initialize! Item was removed: - ----- Method: FileChooser>>addFullPanesTo:from: (in category 'ui creation') ----- - addFullPanesTo: aMorph from: aCollection - aCollection do: [ :each | - | frame | - frame := LayoutFrame - fractions: each second - offsets: each third. - aMorph addMorph: each first fullFrame: frame. - ]! Item was removed: - ----- Method: FileChooser>>buttonPane (in category 'accessing') ----- - buttonPane - ^buttonPane! Item was removed: - ----- Method: FileChooser>>cancelButton (in category 'accessing') ----- - cancelButton - ^cancelButton! Item was removed: - ----- Method: FileChooser>>caption (in category 'accessing') ----- - caption - ^caption! Item was removed: - ----- Method: FileChooser>>captionPane (in category 'accessing') ----- - captionPane - ^captionPane! Item was removed: - ----- Method: FileChooser>>centerMorphicView (in category 'ui creation') ----- - centerMorphicView - self morphicView - fullBounds; - position: Display extent - self morphicView extent // 2. - ! Item was removed: - ----- Method: FileChooser>>createCancelButton (in category 'ui creation') ----- - createCancelButton - cancelButton := SimpleButtonMorph new. - cancelButton - label: 'Cancel' translated; - color: Color transparent; - borderColor: Color black; - borderWidth: 1. - cancelButton - on: #mouseUp - send: #cancelHit - to: self. - ^cancelButton - ! Item was removed: - ----- Method: FileChooser>>createDialogBoxButtonPane (in category 'ui creation') ----- - createDialogBoxButtonPane - "Create buttons suitable for a MorphicModel file chooser." - - buttonPane := AlignmentMorph new. - buttonPane - layoutPolicy: ProportionalLayout new; - color: Color transparent; - borderWidth: 0. - self createOkButton. - self createCancelButton. - buttonPane addMorph: self cancelButton - fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.49 @ 1.0) - offsets: (0 @ 0 corner: 0 @ 0)). - buttonPane addMorph: self okButton - fullFrame: (LayoutFrame fractions: (0.51 @ 0 corner: 1.0 @ 1.0) - offsets: (0 @ 0 corner: 0 @ 0)). - ^buttonPane! Item was removed: - ----- Method: FileChooser>>createDialogBoxCaptionPane (in category 'ui creation') ----- - createDialogBoxCaptionPane - "Create a morph to hold the caption string. The caption is created in setCaption:" - - | icon frame | - captionPane := AlignmentMorph new. - captionPane - color: Color transparent; - layoutPolicy: ProportionalLayout new. - - "You can change the caption later by calling setCaption:" - self setCaption: 'Please select a file' translated. - self setCaptionFont: Preferences windowTitleFont. - icon := SketchMorph new. - icon form: MenuIcons openIcon. - captionPane addMorph: icon. - frame := LayoutFrame new. - frame - leftFraction: 0; - topFraction: 0.5; - leftOffset: icon form width // 2; - topOffset: (icon form width // 2) negated. - icon layoutFrame: frame. - ^captionPane! Item was removed: - ----- Method: FileChooser>>createDialogBoxLayout (in category 'ui creation') ----- - createDialogBoxLayout - "Create a layout suitable for a MorphicModel file chooser." - - | inset insetNeg captionTop captionBottom buttonsBottom buttonsTop contentTop contentBottom | - - inset := 6. - insetNeg := inset negated. - captionTop := 0. - captionBottom := 33. - contentTop := captionBottom + inset. - contentBottom := -30 - inset - inset. - buttonsTop := contentBottom + inset. - buttonsBottom := insetNeg. - - self addFullPanesTo: self morphicView - from: { - { - (self captionPane). - (0 @ 0 corner: 1 @ 0). - (0 @ captionTop corner: 0 @ captionBottom) - }. - { - (self buttonPane). - (0 @ 1 corner: 1 @ 1). - (inset @ buttonsTop corner: insetNeg @ buttonsBottom) - }. - { - (self directoryPane). - (0 @ 0 corner: 0.5 @ 1). - (inset @ contentTop corner: insetNeg @ contentBottom) - }. - { - (self filePane). - (0.5 @ 0 corner: 1 @ 1). - (inset @ contentTop corner: insetNeg @ contentBottom) - } - }! Item was removed: - ----- Method: FileChooser>>createDialogBoxMorphicView (in category 'ui creation') ----- - createDialogBoxMorphicView - | m | - m := MorphicModel new - layoutPolicy: ProportionalLayout new; - color: (Color r: 0.9 g: 0.9 b: 0.9); - borderColor: Color gray; - borderWidth: 1; - layoutInset: 0; - extent: 600 at 400. - self setMorphicView: m. - ^m! Item was removed: - ----- Method: FileChooser>>createDialogBoxUI (in category 'ui creation') ----- - createDialogBoxUI - "This method creates UI components and a layout that are suitable for a MorphicModel. Also centers the morphic view in the world. Note that the order of the method calls are important if you modify this." - - self - createDialogBoxMorphicView; - createDialogBoxCaptionPane; - createDialogBoxButtonPane; - createDirectoryPane; - createFilePane; - createDialogBoxLayout; - centerMorphicView. - ^self morphicView! Item was removed: - ----- Method: FileChooser>>createDirectoryPane (in category 'ui creation') ----- - createDirectoryPane - directoryPane := self morphicDirectoryTreePane. - directoryPane borderWidth: 0. - ^directoryPane! Item was removed: - ----- Method: FileChooser>>createFilePane (in category 'ui creation') ----- - createFilePane - filePane := self morphicFileListPane. - filePane borderWidth: 0. - ^filePane! Item was removed: - ----- Method: FileChooser>>createOkButton (in category 'ui creation') ----- - createOkButton - okButton := SimpleButtonMorph new. - okButton - label: 'Open' translated; - color: Color transparent; - borderColor: Color black; - borderWidth: 1. - okButton - on: #mouseUp - send: #okHit - to: self. - ^okButton! Item was removed: - ----- Method: FileChooser>>createSystemWindowButtonPane (in category 'ui creation') ----- - createSystemWindowButtonPane - "Create buttons suitable for a SystemWindow file chooser." - - self optionalButtonSpecs: self okayAndCancelServices. - buttonPane := self optionalButtonRow. - okButton := buttonPane firstSubmorph. - cancelButton := buttonPane firstSubmorph. - ^buttonPane! Item was removed: - ----- Method: FileChooser>>createSystemWindowCaptionPane (in category 'ui creation') ----- - createSystemWindowCaptionPane - "Create a morph to hold the caption string. The caption is created in setCaption:" - - captionPane := AlignmentMorph new. - captionPane - color: Color transparent; - layoutPolicy: ProportionalLayout new. - "You can change the caption later by calling setCaption:" - self setCaption: 'Please select a file' translated. - ^captionPane! Item was removed: - ----- Method: FileChooser>>createSystemWindowLayout (in category 'ui creation') ----- - createSystemWindowLayout - "Create a layout suitable for a SystemWindow file chooser." - - | buttonsHeight | - - buttonsHeight := 33. - - self addFullPanesTo: self morphicView - from: { - { - (self buttonPane). - (0 @ 0 corner: 1 @ 0). - (0 @ 0 corner: 0 @ buttonsHeight) - }. - { - (self directoryPane). - (0 @ 0 corner: 0.5 @ 1). - (0 @ buttonsHeight corner: 0 @ 0) - }. - { - (self filePane). - (0.5 @ 0 corner: 1 @ 1). - (0 @ buttonsHeight corner: 0 @ 0) - } - }! Item was removed: - ----- Method: FileChooser>>createSystemWindowLayoutWithCaptionPane (in category 'ui creation') ----- - createSystemWindowLayoutWithCaptionPane - - | buttonsHeight captionHeight | - - buttonsHeight := 33. - captionHeight := 28. - - self addFullPanesTo: self morphicView - from: { - { - (self captionPane). - (0 @ 0 corner: 1 @ 0). - (0 @ 0 corner: 0 @ captionHeight) - }. - { - (self buttonPane). - (0 @ 0 corner: 1 @ 0). - (0 @ captionHeight corner: 0 @ (captionHeight + buttonsHeight)) - }. - { - (self directoryPane). - (0 @ 0 corner: 0.5 @ 1). - (0 @ (captionHeight + buttonsHeight) corner: 0 @ 0) - }. - { - (self filePane). - (0.5 @ 0 corner: 1 @ 1). - (0 @ (captionHeight + buttonsHeight) corner: 0 @ 0) - } - }! Item was removed: - ----- Method: FileChooser>>createSystemWindowMorphicView (in category 'ui creation') ----- - createSystemWindowMorphicView - | m | - m := SystemWindow labelled: 'Please select a file' translated. "self directory pathName." - "m deleteCloseBox." - self setMorphicView: m.! Item was removed: - ----- Method: FileChooser>>createSystemWindowUI (in category 'ui creation') ----- - createSystemWindowUI - "This method creates UI components and a layout that are suitable for a SystemWindow. Note that the order of the method calls are important." - - self - createSystemWindowMorphicView; - createSystemWindowButtonPane; - createDirectoryPane; - createFilePane; - createSystemWindowLayout. - ^self morphicView! Item was removed: - ----- Method: FileChooser>>createSystemWindowUIWithCaptionPane (in category 'ui creation') ----- - createSystemWindowUIWithCaptionPane - self - createSystemWindowMorphicView; - createSystemWindowCaptionPane; - createSystemWindowButtonPane; - createDirectoryPane; - createFilePane; - createSystemWindowLayoutWithCaptionPane. - ^self morphicView! Item was removed: - ----- Method: FileChooser>>directory (in category 'accessing') ----- - directory - ^super directory! Item was removed: - ----- Method: FileChooser>>directoryPane (in category 'accessing') ----- - directoryPane - ^directoryPane! Item was removed: - ----- Method: FileChooser>>fileNameFormattedFrom:sizePad: (in category 'updating') ----- - fileNameFormattedFrom: entry sizePad: sizePad - "If the short file list flag is false, we send this on to the superclass." - - | nameStr | - showShortFileNames - ifFalse: [^super fileNameFormattedFrom: entry sizePad: sizePad]. - - "Otherwise, just show the name of the file in the file list." - nameStr := (entry isDirectory) - ifTrue: [entry name, self folderString] - ifFalse: [entry name]. - ^nameStr! Item was removed: - ----- Method: FileChooser>>filePane (in category 'accessing') ----- - filePane - ^filePane! Item was removed: - ----- Method: FileChooser>>initializeAsDialogBox (in category 'initialization') ----- - initializeAsDialogBox - self initializeBasicParameters. - self createDialogBoxUI. - self morphicView - useRoundedCorners; - color: (Color r: 0.9 g: 0.9 b: 0.9); - adoptPaneColor: (Color r: 0.6 g: 0.7 b: 1). - self - setCaptionColor: Color transparent; - setButtonColor: (Color r: 0.9 g: 0.9 b: 0.9). - ! Item was removed: - ----- Method: FileChooser>>initializeAsSystemWindow (in category 'initialization') ----- - initializeAsSystemWindow - self initializeBasicParameters. - self createSystemWindowUI.! Item was removed: - ----- Method: FileChooser>>initializeAsSystemWindowWithCaptionPane (in category 'initialization') ----- - initializeAsSystemWindowWithCaptionPane - self initializeBasicParameters. - self createSystemWindowUIWithCaptionPane.! Item was removed: - ----- Method: FileChooser>>initializeBasicParameters (in category 'initialization') ----- - initializeBasicParameters - self showShortFileNames: true. - self setDirectory: FileDirectory default.! Item was removed: - ----- Method: FileChooser>>morphicView (in category 'accessing') ----- - morphicView - ^view! Item was removed: - ----- Method: FileChooser>>okButton (in category 'accessing') ----- - okButton - ^okButton! Item was removed: - ----- Method: FileChooser>>open (in category 'open') ----- - open - | model | - self postOpen. "Funny name in this context, should be renamed, but whatever..." - self morphicView openInWorld. - UserInterfaceTheme current applyTo: self morphicView allMorphs. - model := self morphicView model. - FileChooser modalLoopOn: self morphicView. - ^ model getSelectedFile. - ! Item was removed: - ----- Method: FileChooser>>setButtonColor: (in category 'ui creation') ----- - setButtonColor: aColor - self okButton color: aColor. - self cancelButton color: aColor. - ! Item was removed: - ----- Method: FileChooser>>setCaption: (in category 'ui creation') ----- - setCaption: aString - | frame | - caption ifNil: - [caption := StringMorph new. - self captionPane addMorph: caption]. - caption contents: aString. - frame := LayoutFrame new. - frame - leftFraction: 0.5; - topFraction: 0.5; - leftOffset: caption width negated // 2; - topOffset: caption height negated // 2. - caption layoutFrame: frame! Item was removed: - ----- Method: FileChooser>>setCaptionColor: (in category 'ui creation') ----- - setCaptionColor: aColor - self captionPane color: aColor! Item was removed: - ----- Method: FileChooser>>setCaptionFont: (in category 'ui creation') ----- - setCaptionFont: aFont - self caption font: aFont. - self setCaption: self caption contents asString. - - ! Item was removed: - ----- Method: FileChooser>>setDirectory: (in category 'initialization') ----- - setDirectory: aDir - ^super directory: aDir! Item was removed: - ----- Method: FileChooser>>setMorphicView: (in category 'initialization') ----- - setMorphicView: aMorphicModel - view := aMorphicModel. - self modalView: view. - view model: self.! Item was removed: - ----- Method: FileChooser>>setPaneColor: (in category 'ui creation') ----- - setPaneColor: aColor - self morphicView - color: aColor; - adoptPaneColor: aColor. - - ! Item was removed: - ----- Method: FileChooser>>setSuffixes: (in category 'initialization') ----- - setSuffixes: aList - self fileSelectionBlock: [:entry :myPattern | - entry isDirectory - ifTrue: - [false] - ifFalse: - [aList includes: (FileDirectory extensionFor: entry name asLowercase)]]! Item was removed: - ----- Method: FileChooser>>showShortFileNames: (in category 'initialization') ----- - showShortFileNames: aBoolean - showShortFileNames := aBoolean! Item was removed: - ----- Method: FileChooser>>updateButtonRow (in category 'updating') ----- - updateButtonRow - "Prevent updating of the the button row."! Item was removed: - Browser subclass: #FileContentsBrowser - instanceVariableNames: 'packages infoString' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-File Contents Browser'! - - !FileContentsBrowser commentStamp: '<historical>' prior: 0! - I am a class browser view on a fileout (either a source file (.st) or change set (.cs)). I do not actually load the code into to the system, nor do I alter the classes in the image. Use me to vet code in a comfortable way before loading it into your image. - - From a FileList, I can be invoked by selecting a source file and selecting the "browse code" menu item from the yellow button menu. - - I use PseudoClass, PseudoClassOrganizers, and PseudoMetaclass to model the class structure of the source file.! Item was removed: - ----- Method: FileContentsBrowser class>>browseCompressedCodeStream: (in category 'instance creation') ----- - browseCompressedCodeStream: aStandardFileStream - "Browse the selected file in fileIn format." - | unzipped | - unzipped := [MultiByteBinaryOrTextStream - with: (GZipReadStream on: aStandardFileStream) contents asString] - ensure: [aStandardFileStream close]. - unzipped reset. - self browseStream: unzipped named: aStandardFileStream name! Item was removed: - ----- Method: FileContentsBrowser class>>browseFile: (in category 'instance creation') ----- - browseFile: aFilename - "Open a file contents browser on a file of the given name" - - aFilename ifNil: [^ Beeper beep]. - self browseFiles: (Array with: aFilename)! Item was removed: - ----- Method: FileContentsBrowser class>>browseFiles: (in category 'instance creation') ----- - browseFiles: fileList - "Open a browser on the packages found within the files in the list; we expect the list to contain acceptable filename strings. - If there is more than one package found the browser will be a full system browser, otherwise it will be a category browser" - ^ (self createBrowserForPackagesFrom: fileList withEach: [:fileName | - FilePackage fromFileNamed: fileName]) buildAndOpenBrowser - ! Item was removed: - ----- Method: FileContentsBrowser class>>browseStream: (in category 'instance creation') ----- - browseStream: aStream - - aStream setConverterForCode. - ^ self browseStream: aStream named: aStream name! Item was removed: - ----- Method: FileContentsBrowser class>>browseStream:named: (in category 'instance creation') ----- - browseStream: aStream named: aString - "Read an already opened file stream into a browser" - ^ (self createBrowserForStream: aStream named: aString) buildAndOpenBrowser - ! Item was removed: - ----- Method: FileContentsBrowser class>>createBrowserForPackagesFrom:withEach: (in category 'private') ----- - createBrowserForPackagesFrom: collectionOfPackageSources withEach: filePackageCreation - - | browser packageDict organizer | - Cursor wait showWhile: [ - browser := self new. - packageDict := Dictionary new. - organizer := SystemOrganizer defaultList: Array new. - - collectionOfPackageSources do: [:src | | package | - package := filePackageCreation value: src. - packageDict - at: package packageName - put: package. - organizer - classifyAll: package classes keys - under: package packageName]. - - (browser := self systemOrganizer: organizer) - packages: packageDict]. - ^ browser! Item was removed: - ----- Method: FileContentsBrowser class>>createBrowserForStream:named: (in category 'private') ----- - createBrowserForStream: aStream named: aString - - ^ self createBrowserForPackagesFrom: {aStream} withEach: [:stream | - (FilePackage new fullName: aString; fileInFrom: aStream)]! Item was removed: - ----- Method: FileContentsBrowser class>>fileReaderServicesForDirectory: (in category 'file list services') ----- - fileReaderServicesForDirectory: aDirectory - ^{ self serviceBrowseCodeFiles }! Item was removed: - ----- Method: FileContentsBrowser class>>fileReaderServicesForFile:suffix: (in category 'file list services') ----- - fileReaderServicesForFile: fullName suffix: suffix - - ((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ]) - ifTrue: [ ^Array with: self serviceBrowseCode]. - - ^(fullName endsWith: 'cs.gz') - ifTrue: [ Array with: self serviceBrowseCompressedCode ] - ifFalse: [#()] - ! Item was removed: - ----- Method: FileContentsBrowser class>>initialize (in category 'class initialization') ----- - initialize - - FileServices registerFileReader: self! Item was removed: - ----- Method: FileContentsBrowser class>>selectAndBrowseFile: (in category 'file list services') ----- - selectAndBrowseFile: aFileList - "When no file are selected you can ask to browse several of them" - - | selectionPattern files | - selectionPattern := UIManager default request:'What files?' initialAnswer: '*.cs;*.st'. - files := (aFileList directory fileNamesMatching: selectionPattern) - collect: [:each | aFileList directory fullNameFor: each]. - self browseFiles: files. - - - ! Item was removed: - ----- Method: FileContentsBrowser class>>serviceBrowseCode (in category 'file list services') ----- - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'code-file browser' translatedNoop - selector: #browseStream: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' translatedNoop - buttonLabel: 'code' translatedNoop) - argumentGetter: [ :fileList | fileList readOnlyStream ]! Item was removed: - ----- Method: FileContentsBrowser class>>serviceBrowseCodeFiles (in category 'file list services') ----- - serviceBrowseCodeFiles - - ^ (SimpleServiceEntry - provider: self - label: 'browse code files' translatedNoop - selector: #selectAndBrowseFile:) - argumentGetter: [ :fileList | fileList ]; - yourself! Item was removed: - ----- Method: FileContentsBrowser class>>serviceBrowseCompressedCode (in category 'file list services') ----- - serviceBrowseCompressedCode - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'code-file browser' translatedNoop - selector: #browseCompressedCodeStream: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' translatedNoop - buttonLabel: 'code' translatedNoop) - argumentGetter: [ :fileList | fileList readOnlyStream ]! Item was removed: - ----- Method: FileContentsBrowser class>>services (in category 'file list services') ----- - services - "Answer potential file services associated with this class" - - ^ {self serviceBrowseCode}.! Item was removed: - ----- Method: FileContentsBrowser class>>showMessageIcons (in category 'preferences') ----- - showMessageIcons - "Remove this method once PseudoClass implements the methods of the class API required to show the icons." - - ^false! Item was removed: - ----- Method: FileContentsBrowser class>>unload (in category 'class initialization') ----- - unload - - FileServices unregisterFileReader: self ! Item was removed: - ----- Method: FileContentsBrowser>>aboutToStyle: (in category 'edit pane') ----- - aboutToStyle: aStyler - "This is a notification that aStyler is about to re-style its text. - Set the classOrMetaClass in aStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - aStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! Item was removed: - ----- Method: FileContentsBrowser>>browseMessages (in category 'other') ----- - browseMessages - "Open a message set browser of all implementors of the currently selected message" - - self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [ ^nil ])! Item was removed: - ----- Method: FileContentsBrowser>>browseMethodFull (in category 'class list') ----- - browseMethodFull - | myClass | - (myClass := self selectedClassOrMetaClass) ifNotNil: - [ToolSet browse: myClass realClass selector: self selectedMessageName]! Item was removed: - ----- Method: FileContentsBrowser>>browseSenders (in category 'other') ----- - browseSenders - "Create and schedule a message set browser on all senders of the - currently selected message selector. Do nothing if no message is selected." - - self hasMessageSelected - ifTrue: [self systemNavigation browseAllCallsOn: self selectedMessageName]! Item was removed: - ----- Method: FileContentsBrowser>>browseSendersOfMessages (in category 'other') ----- - browseSendersOfMessages - "delegate to plain browseSenders since we can't (easily) find all the enst messages within the not-real method" - - ^self browseSenders! Item was removed: - ----- Method: FileContentsBrowser>>browseVersions (in category 'other') ----- - browseVersions - "Create and schedule a message set browser on all versions of the - currently selected message selector." - | class selector | - (selector := self selectedMessageName) ifNotNil: - [class := self selectedClassOrMetaClass. - (class exists and: [class realClass includesSelector: selector]) ifTrue: - [VersionsBrowser - browseVersionsOf: (class realClass compiledMethodAt: selector) - class: class realClass theNonMetaClass - meta: class realClass isMeta - category: self selectedMessageCategoryName - selector: selector]]! Item was removed: - ----- Method: FileContentsBrowser>>buildAndOpenBrowser (in category 'toolbuilder') ----- - buildAndOpenBrowser - "assemble the spec for a file contents browser, build it and open it" - "The browser may have either the full 4-pane layout or the simpler 3-pane version, depending on whether we have 1 or more packages to look at" - - contentsSymbol := self defaultDiffsSymbol. "#showDiffs or #prettyDiffs" - - ^ self packages size = 1 - ifTrue:[ - self systemCategoryListIndex: 1. - self buildAndOpenCategoryBrowser] - ifFalse: [self buildAndOpenFullBrowser]! Item was removed: - ----- Method: FileContentsBrowser>>buildAnnotationPaneWith: (in category 'toolbuilder') ----- - buildAnnotationPaneWith: builder - - | textSpec | - textSpec := builder pluggableInputFieldSpec new. - textSpec - model: self; - getText: #infoViewContents. - ^textSpec! Item was removed: - ----- Method: FileContentsBrowser>>buildSystemCatListSingletonWith: (in category 'toolbuilder') ----- - buildSystemCatListSingletonWith: aToolBuilder - "Overwritten to change callbacks for menu and keyboard interaction." - ^ aToolBuilder pluggableInputFieldSpec new - model: self ; - getText: #selectedSystemCategoryName ; - setText: nil ; - " keyPress: #systemCatSingletonKey:from: ; - " menu: #packageListMenu:shifted:; - " keyPress: #packageListKey:from:; - " yourself! Item was removed: - ----- Method: FileContentsBrowser>>buildSystemCategoryListWith: (in category 'toolbuilder') ----- - buildSystemCategoryListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #systemCategoryList; - getIndex: #systemCategoryListIndex; - setIndex: #systemCategoryListIndex:; - menu: #packageListMenu:shifted:; - keyPress: #packageListKey:from:. - ^listSpec! Item was removed: - ----- Method: FileContentsBrowser>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "Depending upon whether we have a single package or multiple packages, we use different window specs. " - - self packages ifNil:[^self error: self class name, ' cannot be built without any packages; see class instance creation methods' ]. - ^ self packages size = 1 - ifTrue:[ - self systemCategoryListIndex: 1; - buildCategoryBrowserWith: builder] - ifFalse: [super buildWith: builder]! Item was removed: - ----- Method: FileContentsBrowser>>changeMessageCategories: (in category 'other') ----- - changeMessageCategories: aString - "The characters in aString represent an edited version of the the message - categories for the selected class. Update this information in the system - and inform any dependents that the categories have been changed. This - message is invoked because the user had issued the categories command - and edited the message categories. Then the user issued the accept - command." - - self classOrMetaClassOrganizer changeFromString: aString. - self editClass. - self selectClassNamed: selectedClassName. - ^ true! Item was removed: - ----- Method: FileContentsBrowser>>classList (in category 'class list') ----- - classList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - - (self hasSystemCategorySelected not or:[self selectedPackage isNil]) - ifTrue: [^Array new] - ifFalse: [^self selectedPackage classes keys asArray sort].! Item was removed: - ----- Method: FileContentsBrowser>>classListKey:from: (in category 'keys') ----- - classListKey: aChar from: view - aChar == $b ifTrue: [^ self browseMethodFull]. - aChar == $N ifTrue: [^ self browseClassRefs]. - self packageListKey: aChar from: view! Item was removed: - ----- Method: FileContentsBrowser>>classListMenu:shifted: (in category 'menus') ----- - classListMenu: aMenu shifted: aBool - - ^ self menu: aMenu for: #(fileClassListMenu fileClassListMenuShifted:) shifted: aBool - ! Item was removed: - ----- Method: FileContentsBrowser>>contents (in category 'accessing') ----- - contents - self updateInfoView. - (editSelection == #newClass and:[self selectedPackage notNil]) - ifTrue: [^self selectedPackage packageInfo]. - editSelection == #editClass - ifTrue:[^self modifiedClassDefinition]. - ^super contents! Item was removed: - ----- Method: FileContentsBrowser>>contents:notifying: (in category 'accessing') ----- - contents: input notifying: aController - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on the - list selections (such as templates for class or message definition, methods) - or the user menu commands (such as definition, comment, hierarchy). - Answer the result of updating the source." - - | aString aText theClass | - aString := input asString. - aText := input asText. - - editSelection == #editComment - ifTrue: [theClass := self selectedClass. - theClass ifNil: [self inform: 'You must select a class - before giving it a comment.'. - ^ false]. - theClass comment: aText. ^ true]. - editSelection == #editMessageCategories - ifTrue: [^ self changeMessageCategories: aString]. - - self inform:'You cannot change the current selection'. - ^false - ! Item was removed: - ----- Method: FileContentsBrowser>>contentsSymbolQuints (in category 'menus') ----- - contentsSymbolQuints - "Answer a list of quintuplets representing information on the alternative views available in the code pane. For the file-contents browser, the choices are restricted to source and the two diffing options" - - ^ self sourceAndDiffsQuintsOnly! Item was removed: - ----- Method: FileContentsBrowser>>defaultBrowserTitle (in category 'toolbuilder') ----- - defaultBrowserTitle - ^ 'File Contents Browser' ! Item was removed: - ----- Method: FileContentsBrowser>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.7 g: 0.7 b: 0.508)! Item was removed: - ----- Method: FileContentsBrowser>>didCodeChangeElsewhere (in category 'other') ----- - didCodeChangeElsewhere - "Determine whether the code for the currently selected method and class has been changed somewhere else." - - | aClass | - (aClass := self selectedClassOrMetaClass) ifNil: [^ false]. - - (aClass isKindOf: PseudoClass) ifTrue: [^ false]. "class not installed" - ^super didCodeChangeElsewhere! Item was removed: - ----- Method: FileContentsBrowser>>extraInfo (in category 'infoView') ----- - extraInfo - ^ (self - methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) - class: self selectedClass - selector: self selectedMessageName - meta: self metaClassIndicated) unembellished - ifTrue: [' - identical'] - ifFalse: [' - modified']! Item was removed: - ----- Method: FileContentsBrowser>>fileClassListMenu: (in category 'menus') ----- - fileClassListMenu: aMenu - "Answer the class list menu, ignoring the state of the shift key in this case" - <fileClassListMenu> - aMenu addList: #( - ('definition' editClass) - ('comment' editComment) - - - ('browse full (b)' browseMethodFull) - ('class refs (N)' browseClassRefs) - - - ('fileIn' fileInClass) - ('fileOut' fileOutClass) - - - ('rename...' renameClass) - ('remove' removeClass) - ('remove existing' removeUnmodifiedCategories)). - ^ aMenu - ! Item was removed: - ----- Method: FileContentsBrowser>>fileInClass (in category 'fileIn/fileOut') ----- - fileInClass - Cursor read showWhile:[ - self selectedClass fileIn. - ].! Item was removed: - ----- Method: FileContentsBrowser>>fileInMessage (in category 'fileIn/fileOut') ----- - fileInMessage - - self selectedMessageName ifNil: [^self]. - Cursor read showWhile: [ - self selectedClassOrMetaClass fileInMethod: self selectedMessageName. - ].! Item was removed: - ----- Method: FileContentsBrowser>>fileInMessageCategories (in category 'fileIn/fileOut') ----- - fileInMessageCategories - Cursor read showWhile:[ - self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName. - ].! Item was removed: - ----- Method: FileContentsBrowser>>fileInPackage (in category 'fileIn/fileOut') ----- - fileInPackage - Cursor read showWhile:[ - self selectedPackage fileIn. - ].! Item was removed: - ----- Method: FileContentsBrowser>>fileIntoNewChangeSet (in category 'fileIn/fileOut') ----- - fileIntoNewChangeSet - | p ff | - (p := self selectedPackage) ifNil: [^ Beeper beep]. - ff := FileStream readOnlyFileNamed: p fullPackageName. - ChangeSet newChangesFromStream: ff named: p packageName! Item was removed: - ----- Method: FileContentsBrowser>>fileMessageCategoryMenu: (in category 'menus') ----- - fileMessageCategoryMenu: aMenu - <fileMessageCategoryMenu> - ^ aMenu addList: #( - ('file in' fileInMessageCategories) - ('file out' fileOutMessageCategories) - - - ('reorganize' editMessageCategories) - - - ('add item...' addCategory) - ('rename...' renameCategory) - ('remove' removeMessageCategory) - - - ('remove existing' removeUnmodifiedMethods)); - yourself - ! Item was removed: - ----- Method: FileContentsBrowser>>fileMessageListMenu: (in category 'menus') ----- - fileMessageListMenu: aMenu - <fileMessageListMenu> - aMenu addList: #( - ('fileIn' fileInMessage) - ('fileOut' fileOutMessage) - - - ('senders (n)' browseSenders) - ('implementors (m)' browseImplementors) - ('method inheritance (h)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('remove' removeMessage)). - ^ aMenu - ! Item was removed: - ----- Method: FileContentsBrowser>>fileOutClass (in category 'fileIn/fileOut') ----- - fileOutClass - Cursor write showWhile:[ - self selectedClass fileOut. - ].! Item was removed: - ----- Method: FileContentsBrowser>>fileOutMessageCategories (in category 'fileIn/fileOut') ----- - fileOutMessageCategories - Cursor write showWhile:[ - self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName. - ].! Item was removed: - ----- Method: FileContentsBrowser>>fileOutPackage (in category 'fileIn/fileOut') ----- - fileOutPackage - Cursor write showWhile:[ - self selectedPackage fileOut. - ].! Item was removed: - ----- Method: FileContentsBrowser>>filePackageListMenu: (in category 'menus') ----- - filePackageListMenu: aMenu - <filePackageListMenu> - ^ aMenu addList: #( - ('find class... (f)' findClass) - - - ('file in' fileInPackage) - ('file into new changeset' fileIntoNewChangeSet) - ('file out' fileOutPackage) - - - ('remove' removePackage) - - - ('remove existing' removeUnmodifiedClasses)); - yourself - ! Item was removed: - ----- Method: FileContentsBrowser>>findClass (in category 'class list') ----- - findClass - | pattern foundClass classNames index foundPackage | - self okToChange ifFalse: [^ self classNotFound]. - pattern := (UIManager default 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 selectSystemCategory: foundPackage packageName asSymbol. - self classListIndex: (self classList indexOf: foundClass name). ! Item was removed: - ----- Method: FileContentsBrowser>>formattedLabel:forSelector:inClass: (in category 'message list') ----- - formattedLabel: aString forSelector: aSymbol inClass: aPseudoClass - "We have no way get compiled methods for a pseudo class." - - ^ aString! Item was removed: - ----- Method: FileContentsBrowser>>hasClassSelected (in category 'class list') ----- - hasClassSelected - ^ selectedClassName notNil ! Item was removed: - ----- Method: FileContentsBrowser>>infoString (in category 'infoView') ----- - infoString - ^infoString ifNil: [infoString := StringHolder new]! Item was removed: - ----- Method: FileContentsBrowser>>infoViewContents (in category 'infoView') ----- - infoViewContents - "Answer the string to show in the info view" - - | theClass stamp exists | - editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage]. - self selectedClass isNil ifTrue: [^ '']. - theClass := Smalltalk at: self selectedClass name asSymbol ifAbsent: []. - editSelection == #editClass ifTrue: - [^ theClass notNil - ifTrue: ['Class exists already in the system' translated] - ifFalse: ['New class' translated]]. - editSelection == #editMessage ifFalse: [^ '']. - (theClass notNil and: [self metaClassIndicated]) - ifTrue: [theClass := theClass class]. - - stamp := self selectedClassOrMetaClass stampAt: self selectedMessageName. - exists := theClass notNil and: [theClass includesSelector: self selectedMessageName]. - ^ stamp = 'methodWasRemoved' - ifTrue: - [exists - ifTrue: - ['Existing method removed by this change-set' translated] - ifFalse: - ['Removal request for a method that is not present in this image' translated]] - ifFalse: - [stamp, ' · ', - (exists - ifTrue: ['Method already exists' translated , self extraInfo] - ifFalse: ['New method' translated])]! Item was removed: - ----- Method: FileContentsBrowser>>labelString (in category 'other') ----- - labelString - "Answer the string for the window title" - - ^ 'File Contents Browser ', (self selectedSystemCategory ifNil: [''])! Item was removed: - ----- Method: FileContentsBrowser>>messageCategoryMenu: (in category 'menus') ----- - messageCategoryMenu: aMenu - ^ self menu: aMenu for: #(fileMessageCategoryMenu fileMessageCategoryMenuShifted:) - ! Item was removed: - ----- Method: FileContentsBrowser>>messageListKey:from: (in category 'keys') ----- - messageListKey: aChar from: view - aChar == $b ifTrue: [^ self browseMethodFull]. - super messageListKey: aChar from: view! Item was removed: - ----- Method: FileContentsBrowser>>messageListMenu:shifted: (in category 'menus') ----- - messageListMenu: aMenu shifted: aBool - - ^ self menu: aMenu for: #(fileMessageListMenu fileMessageListMenuShifted:) shifted: aBool - ! Item was removed: - ----- Method: FileContentsBrowser>>methodDiffFor:class:selector:meta: (in category 'diffs') ----- - methodDiffFor: aString class: aPseudoClass selector: selector meta: meta - "Answer the diff between the current copy of the given class/selector/meta for the string provided" - - | theClass source | - theClass := Smalltalk - at: aPseudoClass name - ifAbsent: [^ aString copy]. - meta - ifTrue: [theClass := theClass class]. - (theClass includesSelector: selector) - ifFalse: [^ aString copy]. - source := theClass sourceCodeAt: selector. - ^ Cursor wait - showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass prettyDiffs: self showingPrettyDiffs]! Item was removed: - ----- Method: FileContentsBrowser>>methodHierarchy (in category 'other') ----- - methodHierarchy - (self selectedClassOrMetaClass isNil or: - [self selectedClassOrMetaClass hasDefinition]) - ifFalse: [super methodHierarchy]! Item was removed: - ----- Method: FileContentsBrowser>>modifiedClassDefinition (in category 'diffs') ----- - modifiedClassDefinition - | pClass rClass old new diff | - pClass := self selectedClassOrMetaClass. - pClass hasDefinition ifFalse:[^pClass definition]. - rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent:[nil]. - rClass isNil ifTrue:[^pClass definition]. - self metaClassIndicated ifTrue:[ rClass := rClass class]. - old := rClass definition. - new := pClass definition. - diff := Cursor wait showWhile:[ - ClassDiffBuilder buildDisplayPatchFrom: old to: new - ]. - ^diff! Item was removed: - ----- Method: FileContentsBrowser>>packageInfo: (in category 'infoView') ----- - packageInfo: p - | nClasses newClasses oldClasses | - p isNil ifTrue:[^'']. - nClasses := newClasses := oldClasses := 0. - p classes do:[:cls| - nClasses := nClasses + 1. - (Smalltalk hasClassNamed: cls name) - ifTrue:[oldClasses := oldClasses + 1] - ifFalse:[newClasses := newClasses + 1]]. - ^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'! Item was removed: - ----- Method: FileContentsBrowser>>packageListKey:from: (in category 'keys') ----- - packageListKey: aChar from: view - aChar == $f ifTrue: [^ self findClass]. - self arrowKey: aChar from: view! Item was removed: - ----- Method: FileContentsBrowser>>packageListMenu:shifted: (in category 'menus') ----- - packageListMenu: aMenu shifted: shifted - - ^ self menu: aMenu for: #(filePackageListMenu filePackageListMenuShifted:) shifted: shifted - ! Item was removed: - ----- Method: FileContentsBrowser>>packages (in category 'accessing') ----- - packages - ^packages! Item was removed: - ----- Method: FileContentsBrowser>>packages: (in category 'accessing') ----- - packages: aDictionary - packages := aDictionary.! Item was removed: - ----- Method: FileContentsBrowser>>removeMessage (in category 'removing') ----- - removeMessage - - self hasMessageSelected ifFalse: [^ false]. - - super removeMessage ifFalse: [^ false]. - self selectMessageNamed: nil. - self setClassOrganizer. - "In case organization not cached" - self changed: #messageList.! Item was removed: - ----- Method: FileContentsBrowser>>removeMessageCategory (in category 'removing') ----- - removeMessageCategory - "If a message category is selected, create a Confirmer so the user can - verify that the currently selected message category should be removed - from the system. If so, remove it." - - | messageCategoryName | - self hasMessageCategorySelected ifFalse: [^ self]. - self okToChange ifFalse: [^ self]. - messageCategoryName := self selectedMessageCategoryName. - (self messageList size = 0 - or: [self confirm: 'Are you sure you want to - remove this method category - and all its methods?']) ifFalse: [^ self]. - self selectedClassOrMetaClass removeCategory: messageCategoryName. - self messageCategoryListIndex: 0. - self changed: #messageCategoryList.! Item was removed: - ----- Method: FileContentsBrowser>>removePackage (in category 'removing') ----- - removePackage - self hasSystemCategorySelected ifTrue: [^ self]. - self okToChange ifFalse: [^ self]. - (self confirm: 'Are you sure you want to - remove this package - and all its classes?') ifFalse:[^self]. - (systemOrganizer listAtCategoryNamed: self selectedSystemCategory) do:[:el| - systemOrganizer removeElement: el]. - self packages removeKey: self selectedPackage packageName. - systemOrganizer removeCategory: self selectedSystemCategory. - self selectSystemCategory: nil. - self changed: #systemCategoryList! Item was removed: - ----- Method: FileContentsBrowser>>removeUnmodifiedCategories (in category 'removing') ----- - removeUnmodifiedCategories - | theClass | - self okToChange ifFalse: [^self]. - theClass := self selectedClass. - theClass isNil ifTrue: [^self]. - Cursor wait showWhile: - [theClass removeUnmodifiedMethods: theClass selectors. - theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors]. - self messageCategoryListIndex: 0. - self changed: #messageCategoryList.! Item was removed: - ----- Method: FileContentsBrowser>>removeUnmodifiedClasses (in category 'removing') ----- - removeUnmodifiedClasses - | packageList | - self okToChange ifFalse:[^self]. - packageList := self selectedPackage - ifNil: [ self packages] - ifNotNil: [ Array with: self selectedPackage]. - packageList do:[:package| - package classes copy do:[:theClass| - Cursor wait showWhile:[ - theClass removeAllUnmodified. - ]. - theClass hasChanges ifFalse:[ - package removeClass: theClass. - ]. - ]]. - self classListIndex: 0. - self changed: #classList! Item was removed: - ----- Method: FileContentsBrowser>>removeUnmodifiedMethods (in category 'removing') ----- - removeUnmodifiedMethods - | theClass cat | - self okToChange ifFalse:[^self]. - theClass := self selectedClassOrMetaClass. - theClass ifNil: [ ^self]. - cat := self selectedMessageCategoryName. - cat ifNil: [ ^self]. - Cursor wait showWhile:[ - theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat). - ]. - self messageListIndex: 0. - self changed: #messageList.! Item was removed: - ----- Method: FileContentsBrowser>>renameClass (in category 'class list') ----- - renameClass - | oldName newName | - self hasClassSelected ifFalse: [^ self]. - self okToChange ifFalse: [^ self]. - oldName := self selectedClass name. - newName := (self request: 'Please type new class name' - initialAnswer: oldName) asSymbol. - (newName isEmpty or:[newName = oldName]) ifTrue: [^ self]. - (self selectedPackage classes includesKey: newName) - ifTrue: [^ self error: newName , ' already exists in the package']. - systemOrganizer classify: newName under: self selectedSystemCategory. - systemOrganizer removeElement: oldName. - self selectedPackage renameClass: self selectedClass to: newName. - self changed: #classList. - self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategory) indexOf: newName). - ! Item was removed: - ----- Method: FileContentsBrowser>>selectedBytecodes (in category 'edit pane') ----- - selectedBytecodes - "Compile the source code for the selected message selector and extract and return - the bytecode listing." - | class selector | - class := self selectedClassOrMetaClass. - selector := self selectedMessageName. - contents := class sourceCodeAt: selector. - contents := Compiler new - parse: contents - in: class - notifying: nil. - contents := contents generate. - ^ contents symbolic asText! Item was removed: - ----- Method: FileContentsBrowser>>selectedClass (in category 'class list') ----- - selectedClass - "Answer the class that is currently selected. Answer nil if no selection - exists." - - self selectedClassName == nil ifTrue: [^nil]. - ^self selectedPackage classAt: self selectedClassName! Item was removed: - ----- Method: FileContentsBrowser>>selectedClassOrMetaClass (in category 'metaclass') ----- - selectedClassOrMetaClass - "Answer the selected class or metaclass." - - | cls | - self metaClassIndicated - ifTrue: [^ (cls := self selectedClass) ifNotNil: [cls metaClass]] - ifFalse: [^ self selectedClass]! Item was removed: - ----- Method: FileContentsBrowser>>selectedMessage (in category 'edit pane') ----- - selectedMessage - "Answer a copy of the source code for the selected message selector." - - | class selector | - class := self selectedClassOrMetaClass. - selector := self selectedMessageName. - contents := class sourceCodeAt: selector. - SystemBrowser browseWithPrettyPrint - ifTrue: - [contents := class prettyPrinterClass - format: contents - in: class - notifying: nil - decorated: false]. - self showingAnyKindOfDiffs - ifTrue: - [contents := self - methodDiffFor: contents - class: self selectedClass - selector: self selectedMessageName - meta: self metaClassIndicated]. - ^contents asText makeSelectorBoldIn: class! Item was removed: - ----- Method: FileContentsBrowser>>selectedPackage (in category 'accessing') ----- - selectedPackage - | cat | - cat := self selectedSystemCategory. - cat isNil ifTrue:[^nil]. - ^self packages at: cat asString ifAbsent:[nil]! Item was removed: - ----- Method: FileContentsBrowser>>setClassOrganizer (in category 'metaclass') ----- - setClassOrganizer - "Install whatever organization is appropriate" - | theClass | - classOrganizer := nil. - metaClassOrganizer := nil. - self hasClassSelected ifFalse: [^ self]. - classOrganizer := (theClass := self selectedClass) organization. - metaClassOrganizer := theClass metaClass organization. - ! Item was removed: - ----- Method: FileContentsBrowser>>systemCategoryList (in category 'system category list') ----- - systemCategoryList - - ^ self packages size = 1 - ifTrue: [super systemCategoryList allButFirst "without all category"] - ifFalse: [super systemCategoryList]! Item was removed: - ----- Method: FileContentsBrowser>>updateInfoView (in category 'infoView') ----- - updateInfoView - - Smalltalk isMorphic - ifTrue: [self changed: #infoViewContents] - ifFalse: [ - self infoString contents: self infoViewContents. - self infoString changed].! Item was removed: - ----- Method: FileDirectory class>>serviceBrowseDirectory (in category '*Tools-FileList') ----- - serviceBrowseDirectory - - ^ (SimpleServiceEntry - provider: FileList - label: 'browse directory' - selector: #openOn: - description: 'browse directory' - buttonLabel: 'browse') - argumentGetter: [:directory | directory]; - yourself! Item was removed: - StringHolder subclass: #FileList - instanceVariableNames: 'fileName directory volList volListIndex list listIndex pattern sortMode brevityState directoryCache lastGraphicsExtent' - classVariableNames: 'FileReaderRegistry RecentDirs' - poolDictionaries: '' - category: 'Tools-FileList'! - - !FileList commentStamp: 'nk 11/26/2002 11:52' prior: 0! - I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file. - - The FileList now provides a registration mechanism to which any tools the filelist uses ***MUST*** register. This way it is possible to dynamically load or unload a new tool and have the FileList automatically updated. This change supports a decomposition of Squeak and removes a problem with dead reference to classes after a major shrink. - - Tools should implement the following methods (look for implementors in the image): - - #fileReaderServicesForFile:suffix: (appropriate services for given file, takes a file name and a lowercased suffix) - - #services (all provided services, to be displayed in full list) - - These methods both return a collection of SimpleServiceEntry instances. These contain a class, a menu label and a method selector having one argument. They may also provide separate button labels and description. - - The argument to the specified method will be a string representing the full name of a file when one is selected or the file list itself when there is no selected file. - - Tools must register with the FileList calling the class method #registerFileReader: when they load. They also must call #unregisterFileReader: when they unload. - - There is a testSuite called FileListTest that presents some examples. - - Stef (I do not like really this distinction passing always a file list could be better) - - - Old Comments: - - - FileLists can now see FTP servers anywhere on the net. In the volume list menu: - fill in server info... Gives you a form to register a new ftp server you want to use. - open server... Choose a server to connect to. - local disk Go back to looking at your local volume. - - - Still undone (you can contribute code): - [ ] Using a Proxy server to get out through a firewall. What is the convention for proxy servers with FTP? - [ ] Fill in the date and size info in the list of remote files. Allow sorting by it. New smarts needed in (ServerDirectory fileNameFormattedFrom:sizePad:sortMode:). - [ ] Currently the FileList has no way to delete a directory. Since you can't select a directory without going into it, it would have to be deleting the current directory. Which would usually be empty.! Item was removed: - ----- Method: FileList class>>initialize (in category 'class initialization') ----- - initialize - "FileList initialize" - - RecentDirs := OrderedCollection new! Item was removed: - ----- Method: FileList class>>new (in category 'instance creation') ----- - new - ^self newOn: FileDirectory default! Item was removed: - ----- Method: FileList class>>newOn: (in category 'instance creation') ----- - newOn: aDirectory - - ^super new directory: aDirectory! Item was removed: - ----- Method: FileList class>>open (in category 'instance creation') ----- - open - "Open a view of an instance of me on the default directory." - ^ToolBuilder open: self! Item was removed: - ----- Method: FileList class>>openEditorOn:editString: (in category 'instance creation') ----- - openEditorOn: aFileStream editString: editString - "Open an editor on the given FileStream." - | fileModel topView builder | - fileModel := FileList new setFileStream: aFileStream. "closes the stream" - builder := ToolBuilder default. - topView := fileModel buildEditorWith: builder. - ^builder open: topView.! Item was removed: - ----- Method: FileList class>>openFileDirectly (in category 'instance creation') ----- - openFileDirectly - - (FileChooserDialog openOn: FileDirectory default) ifNotNil: - [:fileName | self openEditorOn: (FileStream readOnlyFileNamed: fileName) editString: nil]! Item was removed: - ----- Method: FileList class>>openOn: (in category 'instance creation') ----- - openOn: directory - - ^ToolBuilder open: (self newOn: directory)! Item was removed: - ----- Method: FileList class>>prototypicalToolWindow (in category 'instance creation') ----- - prototypicalToolWindow - "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" - ^ ToolBuilder build: self new! Item was removed: - ----- Method: FileList class>>registerInFlapsRegistry (in category 'class initialization') ----- - registerInFlapsRegistry - "Register the receiver in the system's flaps registry" - self environment - at: #Flaps - ifPresent: [:cl | cl registerQuad: {#FileList . #prototypicalToolWindow, 'File List' translatedNoop. 'A File List is a tool for browsing folders and files on disks and on ftp types.' translatedNoop} - forFlapNamed: 'Tools']! Item was removed: - ----- Method: FileList class>>removeObsolete (in category 'class initialization') ----- - removeObsolete - "FileList removeObsolete" - FileServices removeObsolete - ! Item was removed: - ----- Method: FileList class>>unload (in category 'class initialization') ----- - unload - "Unload the receiver from global registries" - - self environment at: #Flaps ifPresent: [:cl | - cl unregisterQuadsWithReceiver: self] ! Item was removed: - ----- Method: FileList>>addNew:byEvaluating: (in category 'file menu action') ----- - addNew: aString byEvaluating: aBlock - "A parameterization of earlier versions of #addNewDirectory and - #addNewFile. Fixes the bug in each that pushing the cancel button - in the FillInTheBlank dialog gave a walkback." - - | response newName index ending | - self okToChange ifFalse: [^ self]. - (response := UIManager default - request: ('New {1} Name?' translated format: {aString translated}) - initialAnswer: ('{1}Name' translated format: {aString translated})) - isEmpty ifTrue: [^ self]. - newName := response asFileName. - (Cursor wait showWhile: [ - directory fileOrDirectoryExists: newName]) - ifTrue: [^ self inform: ('''{1}'' already exists' translated format: {newName})]. - Cursor wait showWhile: [ - aBlock value: newName]. - self updateFileList. - index := list indexOf: newName. - index = 0 ifTrue: [ending := ') ',newName. - index := list findFirst: [:line | line endsWith: ending]]. - self fileListIndex: index. - ! Item was removed: - ----- Method: FileList>>addNewDirectory (in category 'file menu action') ----- - addNewDirectory - self - addNew: 'Directory' - byEvaluating: [:newName | directory createDirectory: newName] - ! Item was removed: - ----- Method: FileList>>addNewFile (in category 'file menu action') ----- - addNewFile - self - addNew: 'File' - byEvaluating: [:newName | (directory newFileNamed: newName) close] - ! Item was removed: - ----- Method: FileList>>addPath: (in category 'private') ----- - addPath: aString - "Add the given string to the list of recently visited directories." - - | full | - aString ifNil: [^self]. - full := String streamContents: - [ :strm | 2 to: volList size do: - [ :i | strm nextPutAll: (volList at: i) withBlanksTrimmed. - strm nextPut: FileDirectory pathNameDelimiter]]. - full := full, aString. - "Remove and super-directories of aString from the collection." - RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)]. - - "If a sub-directory is in the list, do nothing." - (RecentDirs anySatisfy: [ :aDir | ((full, '*') match: aDir)]) - ifTrue: [^self]. - - [RecentDirs size >= 10] - whileTrue: [RecentDirs removeFirst]. - RecentDirs addLast: full! Item was removed: - ----- Method: FileList>>askServerInfo (in category 'server list') ----- - askServerInfo - "Get the user to create a ServerDirectory for a new server. Fill in and say Accept." - | template | - template := '"Please fill in the following info, then select all text and choose DoIt." - - | aa | - self flag: #ViolateNonReferenceToOtherClasses. - aa := ServerDirectory new. - aa server: ''st.cs.uiuc.edu''. "host" - aa user: ''anonymous''. - aa password: ''yourEmail at school.edu''. - aa directory: ''/Smalltalk/Squeak/Goodies''. - aa url: ''''. "<- this is optional. Only used when *writing* update files." - ServerDirectory addServer: aa named: ''UIUCArchive''. "<- known by this name in Squeak"'. - - (StringHolder new contents: template) openLabel: 'FTP Server Form' - ! Item was removed: - ----- Method: FileList>>availableGraphicsExtent (in category 'private') ----- - availableGraphicsExtent - - ^ self codeTextMorph ifNotNil: [:m | m innerBounds extent - (6 at 22)] - ! Item was removed: - ----- Method: FileList>>buildButtonPaneWith: (in category 'toolbuilder') ----- - buildButtonPaneWith: builder - | panelSpec | - panelSpec := builder pluggablePanelSpec new. - panelSpec - model: self; - children: #getButtonRow; - layout: #horizontal. - ^panelSpec - ! Item was removed: - ----- Method: FileList>>buildCodePaneWith: (in category 'toolbuilder') ----- - buildCodePaneWith: builder - | textSpec | - textSpec := builder pluggableTextSpec new. - textSpec - model: self; - getText: #contents; - setText: #put:; - selection: #contentsSelection; - menu: #fileContentsMenu:shifted:. - ^textSpec! Item was removed: - ----- Method: FileList>>buildContentPaneWith: (in category 'toolbuilder') ----- - buildContentPaneWith: builder - | textSpec | - textSpec := builder pluggableTextSpec new. - textSpec - model: self; - getText: #contents; - setText: #put:; - selection: #contentsSelection; - menu: #fileContentsMenu:shifted:. - ^textSpec - ! Item was removed: - ----- Method: FileList>>buildDirectoryTreeWith: (in category 'toolbuilder') ----- - buildDirectoryTreeWith: builder - | treeSpec | - treeSpec := builder pluggableTreeSpec new. - treeSpec - model: self ; - roots: #rootDirectoryList ; - hasChildren: #hasMoreDirectories: ; - getChildren: #subDirectoriesOf: ; - getSelectedPath: #selectedPath ; - setSelected: #setDirectoryTo: ; - getSelected: #directory; - label: #directoryNameOf: ; - menu: #volumeMenu: ; - autoDeselect: false. - SystemBrowser browseWithDragNDrop ifTrue: - [ treeSpec - dragItem: #dragFromDirectoryList: ; - dropItem: #drop:ontoDirectory:shouldCopy: ; - dropAccept: #wantsDraggedObject: ]. - ^ treeSpec! Item was removed: - ----- Method: FileList>>buildEditorWith: (in category 'toolbuilder') ----- - buildEditorWith: builder - ^super buildWith: builder! Item was removed: - ----- Method: FileList>>buildFileListWith: (in category 'toolbuilder') ----- - buildFileListWith: builder - | buttons listSpec top | - top := builder pluggablePanelSpec new. - top children: OrderedCollection new. - buttons := self buildButtonPaneWith: builder. - buttons frame: - (self - topConstantHeightFrame: self buttonHeight - fromLeft: 0 - width: 1). - top children add: buttons. - listSpec := builder pluggableListSpec new. - listSpec - model: self ; - list: #fileList ; - getIndex: #fileListIndex ; - setIndex: #fileListIndex: ; - menu: #fileListMenu: ; - keyPress: nil ; - frame: - (self - frameOffsetFromTop: self buttonHeight * 1.1 - fromLeft: 0 - width: 1 - bottomFraction: 1) . - SystemBrowser browseWithDragNDrop ifTrue: [ listSpec dragItem: #dragFromFileList: ]. - top children add: listSpec. - ^ top! Item was removed: - ----- Method: FileList>>buildPatternInputWith: (in category 'toolbuilder') ----- - buildPatternInputWith: builder - | textSpec | - textSpec := builder pluggableInputFieldSpec new. - textSpec - model: self; - font: self pathAndPatternFont; - getText: #pathAndPattern; - setText: #pathAndPattern:. - ^textSpec - ! Item was removed: - ----- Method: FileList>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "FileList open" - | windowSpec window | - windowSpec := self buildWindowWith: builder specs: { - (self topConstantHeightFrame: self pathAndPatternHeight - fromLeft: 0 - width: 1) -> [self buildPatternInputWith: builder]. - (self frameOffsetFromTop: self pathAndPatternHeight - fromLeft: 0.25 - width: 0.75 - bottomFraction: 0.5) -> [self buildFileListWith: builder]. - (self frameOffsetFromTop: self pathAndPatternHeight - fromLeft: 0 - width: 0.25 - bottomFraction: 1) -> [self buildDirectoryTreeWith: builder]. - (0.25 at 0.5 corner: 1 at 1) -> [self buildContentPaneWith: builder]. - }. - window := builder build: windowSpec. - self changed: #selectedPath. - ^window! Item was removed: - ----- Method: FileList>>buttonHeight (in category 'toolbuilder') ----- - buttonHeight - ^ ToolBuilder default buttonRowHeight! Item was removed: - ----- Method: FileList>>buttonSelectorsToSuppress (in category 'initialization') ----- - buttonSelectorsToSuppress - "Answer a list of action selectors whose corresponding services we would prefer *not* to have appear in the filelist's button pane; this can be hand-jimmied to suit personal taste." - - ^ #(removeLineFeeds: addFileToNewZip: compressFile: putUpdate:)! Item was removed: - ----- Method: FileList>>compressFile (in category 'file menu action') ----- - compressFile - "Compress the currently selected file" - - | f | - f := StandardFileStream - readOnlyFileNamed: (directory fullNameFor: self fullName). - f compressFile. - self updateFileList! Item was removed: - ----- Method: FileList>>contents (in category 'private') ----- - contents - "Answer the contents of the file, reading it first if needed." - "Possible brevityState values: - FileList, - fullFile, briefFile, needToGetFull, needToGetBrief, - fullHex, briefHex, needToGetFullHex, needToGetBriefHex" - - (listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents]. "no file selected" - brevityState == #fullFile ifTrue: [^ contents]. - brevityState == #fullHex ifTrue: [^ contents]. - brevityState == #briefFile ifTrue: [^ contents]. - brevityState == #briefHex ifTrue: [^ contents]. - brevityState == #graphic ifTrue: [^ contents]. - - brevityState == #needToGetGraphic ifTrue: [^self readGraphicContents]. - - brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false]. - brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true]. - - brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false]. - brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true]. "default" - - (TextConverter allEncodingNames includes: brevityState) - ifTrue: [ ^self readContentsAsEncoding: brevityState]. - - self halt: 'unknown state ' , brevityState printString! Item was removed: - ----- Method: FileList>>copyName (in category 'menu messages') ----- - copyName - - listIndex = 0 ifTrue: [^ self]. - Clipboard clipboardText: self fullName asText. - ! Item was removed: - ----- Method: FileList>>defaultContents (in category 'private') ----- - defaultContents - contents := list == nil - ifTrue: [String new] - ifFalse: [String streamContents: - [:s | s nextPutAll: 'NO FILE SELECTED' translated; cr. - s nextPutAll: ' -- Folder Summary --' translated; cr. - list do: [:item | s nextPutAll: item; cr]]]. - brevityState := #FileList. - ^ contents! Item was removed: - ----- Method: FileList>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.65 g: 0.65 b: 0.65)! Item was removed: - ----- Method: FileList>>deleteDirectory (in category 'volume list and pattern') ----- - deleteDirectory - "Remove the currently selected directory" - | localDirName | - directory hasEntries ifTrue:[^self inform:'Directory must be empty' translated]. - localDirName := directory localName. - (self confirm: ('Really delete {1}?' translated format: {localDirName})) ifFalse: [^ self]. - self volumeListIndex: self volumeListIndex-1. - directory deleteDirectory: localDirName. - self updateFileList.! Item was removed: - ----- Method: FileList>>deleteFile (in category 'file menu action') ----- - deleteFile - "Delete the currently selected file" - listIndex = 0 ifTrue: [^ self]. - (self confirm: ('Really delete {1}?' translated format:{fileName})) ifFalse: [^ self]. - directory deleteFileNamed: fileName. - self updateFileList. - brevityState := #FileList. - self get! Item was removed: - ----- Method: FileList>>dirAndFileName (in category 'file list menu') ----- - dirAndFileName - - ^{directory. fileName}! Item was removed: - ----- Method: FileList>>directory (in category 'volume list and pattern') ----- - directory - - ^ directory! Item was removed: - ----- Method: FileList>>directory: (in category 'initialization') ----- - directory: aFileDirectory - "Set the path of the volume to be displayed." - self okToChange ifFalse: [ ^ self ]. - self modelSleep. - directory := aFileDirectory. - self modelWakeUp. - sortMode == nil ifTrue: [ sortMode := #date ]. - volList := (Array with: '[]') , directory pathParts withIndexCollect: - [ : each : i | (String - new: i - 1 - withAll: Character space) , each ]. - volListIndex := volList size. - self changed: #relabel. - self changed: #volumeList. - self changed: #directory. - self pattern: pattern! Item was removed: - ----- Method: FileList>>directoryNameOf: (in category 'directory tree') ----- - directoryNameOf: aDirectory - "Attempt to find the name of ServerDirectories when used." - - ^(aDirectory isRemoteDirectory and:[aDirectory isKindOf: ServerDirectory]) - ifTrue:[ServerDirectory servers keyAtIdentityValue: aDirectory ifAbsent:[aDirectory localName]] - ifFalse:[aDirectory localName]! Item was removed: - ----- Method: FileList>>dragFromDirectoryList: (in category 'file list') ----- - dragFromDirectoryList: anIndex - ^ self directory! Item was removed: - ----- Method: FileList>>dragFromFileList: (in category 'file list') ----- - dragFromFileList: anIndex - ^ self directory entryAt: (self fileNameFromFormattedItem: (self fileList at: self fileListIndex))! Item was removed: - ----- Method: FileList>>dragPassengerFor:inMorph: (in category 'drag''n''drop') ----- - dragPassengerFor: item inMorph: dragSource - ^self directory fullNameFor: ((self fileNameFromFormattedItem: item contents copy) - copyReplaceAll: self folderString with: ''). - ! Item was removed: - ----- Method: FileList>>drop:ontoDirectory:shouldCopy: (in category 'toolbuilder') ----- - drop: aDirectoryEntryFile ontoDirectory: aFileDirectory shouldCopy: aBoolean - aDirectoryEntryFile containingDirectory = aFileDirectory ifTrue: [ ^ self ]. - aBoolean - ifTrue: [ aFileDirectory copyHere: aDirectoryEntryFile ] - ifFalse: - [ directory - rename: aDirectoryEntryFile fullName - toBe: (aFileDirectory fullNameFor: aDirectoryEntryFile name). - self setDirectoryTo: directory ]! Item was removed: - ----- Method: FileList>>dynamicButtonServices (in category 'initialization') ----- - dynamicButtonServices - "Answer services for buttons that may come and go in the button pane, depending on selection" - - ^ fileName isEmptyOrNil - ifTrue: - [#()] - ifFalse: - [ | toReject | - toReject := self buttonSelectorsToSuppress. - (self itemsForFile: self fullName) reject: - [:svc | toReject includes: svc selector]]! Item was removed: - ----- Method: FileList>>entriesMatching: (in category 'private') ----- - entriesMatching: patternString - "Answer a list of directory entries which match the patternString. - The patternString may consist of multiple patterns separated by ';'. - Each pattern can include a '*' or '#' as wildcards - see String>>match:" - - | entries patterns | - entries := directory entries reject:[:e| Smalltalk isMorphic and: [e isDirectory]]. - patterns := patternString findTokens: ';'. - (patterns anySatisfy: [:each | each = '*']) - ifTrue: [^ entries]. - ^ entries select: [:entry | patterns anySatisfy: [:each | each match: entry name]]! Item was removed: - ----- Method: FileList>>executeService: (in category 'toolbuilder') ----- - executeService: aService - aService performServiceFor: self.! Item was removed: - ----- Method: FileList>>fileContentsMenu:shifted: (in category 'file list menu') ----- - fileContentsMenu: aMenu shifted: shifted - "Construct aMenu to have items appropriate for the file browser's code pane, given the shift state provided" - ^ self menu: aMenu for: #(fileContentsMenu fileContentsMenuShifted:) shifted: shifted! Item was removed: - ----- Method: FileList>>fileList (in category 'file list') ----- - fileList - "Answer the list of files in the current volume." - - ^ list! Item was removed: - ----- Method: FileList>>fileListIndex (in category 'file list') ----- - fileListIndex - "Answer the index of the currently selected file." - - ^ listIndex! Item was removed: - ----- Method: FileList>>fileListIndex: (in category 'file list') ----- - fileListIndex: anInteger - "Select the file name having the given index, and display its contents." - - | item name | - self okToChange ifFalse: [^ self]. - listIndex := anInteger. - listIndex = 0 - ifTrue: [fileName := nil] - ifFalse: - [item := self fileNameFromFormattedItem: (list at: anInteger). - (item endsWith: self folderString) - ifTrue: - ["remove [...] folder string and open the folder" - name := item copyFrom: 1 to: item size - self folderString size. - listIndex := 0. - brevityState := #FileList. - self addPath: name. - name first = $^ - ifTrue: [self directory: (ServerDirectory serverNamed: name allButFirst)] - ifFalse: [volListIndex = 1 ifTrue: [name := name, directory slash]. - self directory: (directory directoryNamed: name)]] - ifFalse: [fileName := item]]. "open the file selected" - - brevityState := self isGraphicsFileSelected - ifTrue: [#needToGetGraphic] - ifFalse: [#needToGetBrief].. - self - changed: #fileListIndex ; - changed: #contents ; - changed: #labelString. - self updateButtonRow! Item was removed: - ----- Method: FileList>>fileListMenu: (in category 'file list menu') ----- - fileListMenu: aMenu - ^ self menu: aMenu for: #(fileListMenu fileListMenuShifted:) - ! Item was removed: - ----- Method: FileList>>fileName (in category 'file list') ----- - fileName - - ^ fileName! Item was removed: - ----- Method: FileList>>fileNameFormattedFrom:sizePad: (in category 'volume list and pattern') ----- - fileNameFormattedFrom: entry sizePad: sizePad - "entry is a 5-element array of the form: - (name creationTime modificationTime dirFlag fileSize)" - | sizeStr nameStr dateStr | - nameStr := entry isDirectory - ifTrue: [entry name , self folderString] - ifFalse: [entry name]. - dateStr := ((Date fromSeconds: entry modificationTime ) - printFormat: #(3 2 1 $. 1 1 2)) , ' ' , - (String streamContents: [:s | - (Time fromSeconds: entry modificationTime \\ 86400) - print24: true on: s]). - sizeStr := entry fileSize asStringWithCommas. - sortMode = #name ifTrue: - [^ nameStr , ' (' , dateStr , ' ' , sizeStr , ')']. - sortMode = #date ifTrue: - [^ '(' , dateStr , ' ' , sizeStr , ') ' , nameStr]. - sortMode = #size ifTrue: - [^ '(' , (String new: sizePad - sizeStr size withAll: Character space) , sizeStr , ' ' , dateStr , ') ' , nameStr]. - ! Item was removed: - ----- Method: FileList>>fileNameFromFormattedItem: (in category 'private') ----- - fileNameFromFormattedItem: item - "Extract fileName and folderString from a formatted fileList item string" - - | from to | - self sortingByName - ifTrue: [ - from := item lastIndexOf: $(. - to := item lastIndexOf: $)] - ifFalse: [ - from := item indexOf: $(. - to := item indexOf: $)]. - ^ (from * to = 0 - ifTrue: [item] - ifFalse: [item copyReplaceFrom: from to: to with: '']) withBlanksTrimmed! Item was removed: - ----- Method: FileList>>fileSelectedMenu: (in category 'file list menu') ----- - fileSelectedMenu: aMenu - - | firstItems secondItems thirdItems n1 n2 n3 services | - firstItems := self itemsForFile: self fullName. - secondItems := self itemsForAnyFile. - thirdItems := self itemsForNoFile. - n1 := firstItems size. - n2 := n1 + secondItems size. - n3 := n2 + thirdItems size. - services := firstItems, secondItems, thirdItems, self serviceAllFileOptions. - services do: [ :svc | svc addDependent: self ]. - ^ aMenu - addServices2: services - for: self - extraLines: (Array with: n1 with: n2 with: n3) - ! Item was removed: - ----- Method: FileList>>folderString (in category 'private') ----- - folderString - ^ ' [...]'! Item was removed: - ----- Method: FileList>>frameOffsetFromTop:fromLeft:width:bottomFraction: (in category 'toolbuilder') ----- - frameOffsetFromTop: height fromLeft: leftFraction width: rightFraction bottomFraction: bottomFraction - ^LayoutFrame new - topFraction: 0 offset: height; - leftFraction: leftFraction offset: 0; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: bottomFraction offset: 0; - yourself.! Item was removed: - ----- Method: FileList>>fullFileListMenu:shifted: (in category 'file list menu') ----- - fullFileListMenu: aMenu shifted: aBoolean - "Fill the menu with all possible items for the file list pane, regardless of selection." - - | lastProvider | - aMenu title: 'all possible file operations' translated. - aMenu addStayUpItemSpecial. - - lastProvider := nil. - (self itemsForFile: self fullName) do: [ :svc | - (lastProvider notNil and: [svc provider ~~ lastProvider]) - ifTrue: [ aMenu addLine ]. - svc addServiceFor: self toMenu: aMenu. - Smalltalk isMorphic ifTrue: [aMenu submorphs last setBalloonText: svc description]. - lastProvider := svc provider. - svc addDependent: self. - ]. - - ^aMenu! Item was removed: - ----- Method: FileList>>fullName (in category 'private') ----- - fullName - "Answer the full name for the currently selected file; answer nil if no file is selected." - - ^ fileName ifNotNil: [directory - ifNil: - [FileDirectory default fullNameFor: fileName] - ifNotNil: - [directory fullNameFor: fileName]] - ! Item was removed: - ----- Method: FileList>>get (in category 'file menu action') ----- - get - "Get contents of file again, it may have changed. Do this by making the cancel string be the contents, and doing a cancel." - - Cursor read showWhile: [ - self okToChange ifFalse: [^ nil]. - brevityState == #briefHex - ifTrue: [brevityState := #needToGetFullHex] - ifFalse: [brevityState := #needToGetFull]. - self changed: #contents]. - ! Item was removed: - ----- Method: FileList>>getButtonRow (in category 'toolbuilder') ----- - getButtonRow - "Answer the dynamic button row to use for the currently selected item." - | builder svc | - builder := ToolBuilder default. - svc := self universalButtonServices. - self fileListIndex = 0 ifFalse:[svc := svc, self dynamicButtonServices]. - ^svc collect:[:service| service buildWith: builder in: self].! Item was removed: - ----- Method: FileList>>getEncodedText (in category 'file menu action') ----- - getEncodedText - - Cursor read showWhile: [ - self selectEncoding. - self changed: #contents]. - ! Item was removed: - ----- Method: FileList>>getHex (in category 'file menu action') ----- - getHex - "Get contents of file again, and display in Hex. Do this by making the cancel string be the contents, and doing a cancel." - - Cursor read showWhile: [ - brevityState := #needToGetBriefHex. - self changed: #contents]. - ! Item was removed: - ----- Method: FileList>>getSelectedPath (in category 'directory tree') ----- - getSelectedPath - self halt.! Item was removed: - ----- Method: FileList>>hasMoreDirectories: (in category 'directory tree') ----- - hasMoreDirectories: aDirectory - (aDirectory isKindOf: FileDirectory) ifFalse:[^true]. "server directory; don't ask" - ^directoryCache at: aDirectory ifAbsentPut:[ - [aDirectory directoryNames notEmpty] on: Error do:[:ex| true]. - ].! Item was removed: - ----- Method: FileList>>initialize (in category 'initialization') ----- - initialize - super initialize. - directoryCache := WeakIdentityKeyDictionary new.! Item was removed: - ----- Method: FileList>>isFileSelected (in category 'private') ----- - isFileSelected - "return if a file is currently selected" - - ^ fileName notNil! Item was removed: - ----- Method: FileList>>isGraphicsFileSelected (in category 'private') ----- - isGraphicsFileSelected - ^fileName notNil - and: [(self itemsForFile: self fullName) anySatisfy: [:each | each provider == Form and: [each selector == #importImage:]]]! Item was removed: - ----- Method: FileList>>itemsForAnyFile (in category 'file list menu') ----- - itemsForAnyFile - "Answer a list of universal services that could apply to any file" - - | services | - services := OrderedCollection new: 4. - services add: self serviceCopyName. - services add: self serviceRenameFile. - services add: self serviceDeleteFile. - services add: self serviceViewContentsInWorkspace. - ^ services! Item was removed: - ----- Method: FileList>>itemsForDirectory: (in category 'file list menu') ----- - itemsForDirectory: dir - | services | - services := OrderedCollection new. - dir ifNotNil: [ - services - addAll: (FileServices itemsForDirectory: dir). - services last useLineAfter: true. ]. - services add: self serviceAddNewFile. - services add: self serviceAddNewDirectory. - ^ services! Item was removed: - ----- Method: FileList>>itemsForFile: (in category 'file list menu') ----- - itemsForFile: fullName - "Answer a list of services appropriate for a file of the given full name" - ^ (FileServices itemsForFile: fullName) , (self myServicesForFile: fullName suffix: (FileServices suffixOf: fullName))! Item was removed: - ----- Method: FileList>>itemsForNoFile (in category 'file list menu') ----- - itemsForNoFile - - | services | - services := OrderedCollection new. - services add: self serviceSortByName. - services add: self serviceSortBySize. - services add: (self serviceSortByDate useLineAfter: true). - services addAll: (self itemsForDirectory: (self isFileSelected ifFalse: [ self directory ] ifTrue: [])). - ^ services - - ! Item was removed: - ----- Method: FileList>>labelString (in category 'initialization') ----- - labelString - ^ directory - ifNil: [ 'File List' ] - ifNotNil: - [ fileName - ifNil: [ directory fullName ] - ifNotNil: [ directory fullNameFor: fileName ] ]! Item was removed: - ----- Method: FileList>>listForPattern: (in category 'volume list and pattern') ----- - listForPattern: pat - "Make the list be those file names which match the pattern." - - | sizePad newList | - newList := (self entriesMatching: pat) asArray sort: self sortBlock. - sizePad := (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) - asStringWithCommas size - 1. - newList := newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. - - volList size = 1 ifTrue: - ["Include known servers along with other desktop volumes" - ^ newList , - (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])]. - ^ newList! Item was removed: - ----- Method: FileList>>listForPatterns: (in category 'private') ----- - listForPatterns: anArray - "Make the list be those file names which match the pattern." - - | sizePad newList | - newList := Set new. - anArray do: [ :pat | newList addAll: (self entriesMatching: pat) ]. - newList := newList asArray sort: self sortBlock. - sizePad := (newList inject: 0 into: [:mx :entry | mx max: entry fileSize]) - asStringWithCommas size. - newList := newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. - - volList size = 1 ifTrue: - ["Include known servers along with other desktop volumes" - ^ newList , - (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])]. - ^ newList! Item was removed: - ----- Method: FileList>>mainFileContentsMenu: (in category 'file list menu') ----- - mainFileContentsMenu: aMenu - "Construct aMenu to have items appropriate for the file browser's code pane, for the unshifted state" - <fileContentsMenuShifted: false> - ^ aMenu addTranslatedList: #( - ('find... (f)' find) - ('find again (g)' findAgain) - ('find and replace... ' findReplace) - ('do/replace again (j)' again) - - - ('undo (z)' undo) - ('redo (Z)' redo) - - - ('copy (c)' copySelection) - ('cut (x)' cut) - ('paste (v)' paste) - ('paste...' pasteRecent) - - - ('do it (d)' doIt) - ('print it (p)' printIt) - ('inspect it (i)' inspectIt) - ('fileIn selection (G)' fileItIn) - - - ('accept (s)' accept) - ('cancel (l)' cancel) - - - ('more...' shiftedYellowButtonActivity)); - yourself - ! Item was removed: - ----- Method: FileList>>mainFileListMenu: (in category 'file list menu') ----- - mainFileListMenu: aMenu - <fileListMenu> - fileName - ifNil: [^ self noFileSelectedMenu: aMenu] - ifNotNil: [^ self fileSelectedMenu: aMenu]. - ! Item was removed: - ----- Method: FileList>>mainVolumeMenu: (in category 'volume menu') ----- - mainVolumeMenu: aMenu - <volumeMenu> - ^ aMenu addTranslatedList: #( - ('recent...' recentDirs) - - - ('add server...' askServerInfo) - ('remove server...' removeServer) - - - ('delete directory...' deleteDirectory) - -); - yourself! Item was removed: - ----- Method: FileList>>modelSleep (in category 'initialization') ----- - modelSleep - "User has exited or collapsed the window -- close any remote connection." - - directory ifNotNil: [directory sleep]! Item was removed: - ----- Method: FileList>>modelWakeUp (in category 'initialization') ----- - modelWakeUp - "User has entered or expanded the window -- reopen any remote connection." - - (directory notNil and:[directory isRemoteDirectory]) - ifTrue: [[directory wakeUp] on: TelnetProtocolError do: [ :ex | self inform: ex printString ]] "It would be good to implement a null method wakeUp on the root of directory"! Item was removed: - ----- Method: FileList>>myServicesForFile:suffix: (in category 'file list menu') ----- - myServicesForFile: fullName suffix: suffix - - ^(FileStream isSourceFileSuffix: suffix) - ifTrue: [ {self serviceBroadcastUpdate} ] - ifFalse: [ #() ]! Item was removed: - ----- Method: FileList>>noFileSelectedMenu: (in category 'file list menu') ----- - noFileSelectedMenu: aMenu - - ^ aMenu - addServices: self itemsForNoFile - for: self - extraLines: #() - - ! Item was removed: - ----- Method: FileList>>offerAllFileOptions (in category 'file list menu') ----- - offerAllFileOptions - "Put up a menu offering all possible file options, whatever the suffix of the current selection may be. Specially useful if you're wanting to keep the menu up" - - self offerMenuFrom: #fullFileListMenu:shifted: shifted: true! Item was removed: - ----- Method: FileList>>optionalButtonHeight (in category 'initialization') ----- - optionalButtonHeight - - ^ 15! Item was removed: - ----- Method: FileList>>optionalButtonSpecs (in category 'initialization') ----- - optionalButtonSpecs - "Answer a list of services underlying the optional buttons in their initial inception." - - ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}! Item was removed: - ----- Method: FileList>>pathAndPattern (in category 'volume list and pattern') ----- - pathAndPattern - "Answers both path and pattern" - ^directory fullName, directory slash, pattern! Item was removed: - ----- Method: FileList>>pathAndPattern: (in category 'volume list and pattern') ----- - pathAndPattern: stringOrText - "Answers both path and pattern" - | base pat aString | - aString := stringOrText asString. - base := aString copyUpToLast: directory pathNameDelimiter. - pat := aString copyAfterLast: directory pathNameDelimiter. - self changed: #pathAndPattern. "avoid asking if it's okToChange" - pattern := pat. - self directory: (FileDirectory on: base). - self changed: #pathAndPattern. - self changed: #selectedPath.! Item was removed: - ----- Method: FileList>>pathAndPatternFont (in category 'toolbuilder') ----- - pathAndPatternFont - - ^ TextStyle defaultFont! Item was removed: - ----- Method: FileList>>pathAndPatternHeight (in category 'toolbuilder') ----- - pathAndPatternHeight - - ^ ToolBuilder default inputFieldHeight! Item was removed: - ----- Method: FileList>>pattern (in category 'volume list and pattern') ----- - pattern - - ^ pattern ifNil: ['*'] - ! Item was removed: - ----- Method: FileList>>pattern: (in category 'volume list and pattern') ----- - pattern: textOrStringOrNil - - textOrStringOrNil - ifNil: [pattern := '*'] - ifNotNil: [pattern := textOrStringOrNil asString]. - pattern isEmpty ifTrue: [pattern := '*']. - self updateFileList. - ^ true - ! Item was removed: - ----- Method: FileList>>perform:orSendTo: (in category 'menu messages') ----- - perform: selector orSendTo: otherTarget - "Selector was just chosen from a menu by a user. - If it's one of the three sort-by items, handle it specially. - If I can respond myself, then perform it on myself. - If not, send it to otherTarget, presumably the editPane from which the menu was invoked." - - ^ (#(sortByDate sortBySize sortByName) includes: selector) - ifTrue: - [self resort: selector] - ifFalse: - [(#(get getHex copyName openImageInWindow importImage renameFile deleteFile addNewFile) includes: selector) - ifTrue: [self perform: selector] - ifFalse: [super perform: selector orSendTo: otherTarget]]! Item was removed: - ----- Method: FileList>>put: (in category 'private') ----- - put: aText - "Private - put the supplied text onto the file" - - | ff newName contentTypeLabel | - brevityState == #fullFile ifTrue: - [ff := directory newFileNamed: self fullName. - self setDefaultEncoderFor: ff. - Cursor write showWhile: [ff nextPutAll: aText asString; close]. - (directory = ff directory and: [fileName = ff localName]) - ifTrue: [contents := aText asString] - ifFalse: "user changed the directory and/or renamed the file" - [self clearUserEditFlag. - directory ~= ff directory ifTrue: - [self directory: ff directory. - self changed: #rootDirectoryList; changed: #selectedPath]. - self updateFileList. - contents := aText asString. - newName := ff localName. - listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. - listIndex > 0 ifTrue: [fileName := newName]. - brevityState := #needToGetBrief. - self changed: #fileListIndex]. - self changed: #relabel. - ^ true "accepted"]. - - listIndex = 0 ifTrue: - [self inform: 'No fileName is selected' translated. - ^ false "failed"]. - contentTypeLabel := 'These contents' translated. - brevityState = #briefFile ifTrue: [contentTypeLabel := 'Abbreviated contents' translated]. - brevityState = #briefHex ifTrue: [contentTypeLabel := 'Abbreviated contents' translated]. - brevityState = #fullHex ifTrue: [contentTypeLabel := 'Hexadecimal contents' translated]. - brevityState = #FileList ifTrue: [contentTypeLabel := 'Directory contents' translated]. - self inform: ('{1} cannot - meaningfully be saved at present.' translated format: {'Abbreviated contents' translated}). - ^ false "failed" - ! Item was removed: - ----- Method: FileList>>readContentsAsEncoding: (in category 'private') ----- - readContentsAsEncoding: encodingName - | f writeStream converter c | - f := directory oldFileOrNoneNamed: self fullName. - f ifNil: [^ 'For some reason, this file cannot be read']. - writeStream := WriteStream on: String new. - converter := TextConverter defaultConverterClassForEncoding: encodingName. - converter ifNil: [^ 'This encoding is not supported']. - f converter: converter new. - f wantsLineEndConversion: true. - [f atEnd or: [(c := f next) isNil]] - whileFalse: [writeStream nextPut: c]. - f close. - ^ writeStream contents! Item was removed: - ----- Method: FileList>>readContentsBrief: (in category 'private') ----- - readContentsBrief: brevityFlag - "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist." - | f fileSize first5000 | - - brevityFlag ifTrue: [ - directory isRemoteDirectory ifTrue: [^ self readServerBrief]]. - f := directory oldFileOrNoneNamed: self fullName. - f ifNil: [^ 'For some reason, this file cannot be read' translated]. - self setDefaultEncoderFor: f. - (brevityFlag not or: [(fileSize := f size) <= 100000]) ifTrue: - [contents := f contentsOfEntireFile. - brevityState := #fullFile. "don't change till actually read" - ^ contents]. - - "if brevityFlag is true, don't display long files when first selected" - first5000 := f next: 5000. - f close. - contents := 'File ''{1}'' is {2} bytes long. - You may use the ''get'' command to read the entire file. - - Here are the first 5000 characters... - ------------------------------------------ - {3} - ------------------------------------------ - ... end of the first 5000 characters.' translated format: {fileName. fileSize. first5000}. - brevityState := #briefFile. "don't change till actually read" - ^ contents. - ! Item was removed: - ----- Method: FileList>>readContentsCNGB (in category 'private') ----- - readContentsCNGB - | f writeStream | - f := directory oldFileOrNoneNamed: self fullName. - f ifNil: [^ 'For some reason, this file cannot be read']. - writeStream := WriteStream on: String new. - f converter: CNGBTextConverter new. - [f atEnd] - whileFalse: [writeStream nextPut: f next]. - f close. - ^ writeStream contents! Item was removed: - ----- Method: FileList>>readContentsEUCJP (in category 'private') ----- - readContentsEUCJP - | f writeStream | - f := directory oldFileOrNoneNamed: self fullName. - f ifNil: [^ 'For some reason, this file cannot be read']. - writeStream := WriteStream on: String new. - f converter: EUCJPTextConverter new. - [f atEnd] - whileFalse: [writeStream nextPut: f next]. - f close. - ^ writeStream contents! Item was removed: - ----- Method: FileList>>readContentsEUCKR (in category 'private') ----- - readContentsEUCKR - | f writeStream | - f := directory oldFileOrNoneNamed: self fullName. - f ifNil: [^ 'For some reason, this file cannot be read']. - writeStream := WriteStream on: String new. - f converter: EUCKRTextConverter new. - [f atEnd] - whileFalse: [writeStream nextPut: f next]. - f close. - ^ writeStream contents! Item was removed: - ----- Method: FileList>>readContentsHex: (in category 'private') ----- - readContentsHex: brevity - "retrieve the contents from the external file unless it is too long. - Don't create a file here. Check if exists." - | f size data hexData s | - - f := directory oldFileOrNoneNamed: self fullName. - f == nil ifTrue: [^ 'For some reason, this file cannot be read' translated]. - f binary. - ((size := f size)) > 5000 & brevity - ifTrue: [data := f next: 10000. f close. brevityState := #briefHex] - ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex]. - - s := WriteStream on: (String new: data size*4). - 0 to: data size-1 by: 16 do: - [:loc | s nextPutAll: loc printStringHex; space; - nextPut: $(; print: loc; nextPut: $); space; tab. - loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) printStringHex; space]. - s cr]. - hexData := s contents. - - ^ contents := ((size > 5000) & brevity - ifTrue: ['File ''{1}'' is {2} bytes long. - You may use the ''get'' command to read the entire file. - - Here are the first 5000 characters... - ------------------------------------------ - {3} - ------------------------------------------ - ... end of the first 5000 characters.' translated format: {fileName. size. hexData}] - ifFalse: [hexData]). - ! Item was removed: - ----- Method: FileList>>readContentsShiftJIS (in category 'private') ----- - readContentsShiftJIS - | f writeStream | - f := directory oldFileOrNoneNamed: self fullName. - f ifNil: [^ 'For some reason, this file cannot be read']. - writeStream := WriteStream on: String new. - f converter: ShiftJISTextConverter new. - [f atEnd] - whileFalse: [writeStream nextPut: f next]. - f close. - ^ writeStream contents! Item was removed: - ----- Method: FileList>>readContentsUTF8 (in category 'private') ----- - readContentsUTF8 - | f writeStream | - f := directory oldFileOrNoneNamed: self fullName. - f ifNil: [^ 'For some reason, this file cannot be read']. - writeStream := WriteStream on: String new. - f converter: UTF8TextConverter new. - [f atEnd] - whileFalse: [writeStream nextPut: f next]. - f close. - ^ writeStream contents! Item was removed: - ----- Method: FileList>>readGraphicContents (in category 'private') ----- - readGraphicContents - | form maxExtent ext | - form := (Form fromFileNamed: self fullName) asFormOfDepth: Display depth. - maxExtent := lastGraphicsExtent := self availableGraphicsExtent. - ext := form extent. - (maxExtent notNil and: [form extent <= maxExtent]) ifFalse: [ - form := form magnify: form boundingBox by: (maxExtent x / form width min: maxExtent y / form height) asPoint smoothing: 3]. - contents := ('Image extent: ', ext printString) asText, - (String with: Character cr), - (Text string: ' ' - attribute: (TextFontReference toFont: - (FormSetFont new - fromFormArray: (Array with: form) - asciiStart: Character space asInteger - ascent: form height))). - brevityState := #graphic. - ^contents! Item was removed: - ----- Method: FileList>>readOnlyStream (in category 'file list') ----- - readOnlyStream - "Answer a read-only stream on the selected file. For the various stream-reading services." - - ^self directory ifNotNil: [ :dir | dir readOnlyFileNamed: self fileName ]! Item was removed: - ----- Method: FileList>>readServerBrief (in category 'private') ----- - readServerBrief - | lString sizeStr fsize ff first5000 parts | - "If file on server is known to be long, just read the beginning. Cheat badly by reading the fileList string." - - listIndex = 0 ifTrue: [^ self]. - "Get size from file list entry" - lString := list at: listIndex. - parts := lString findTokens: '()'. - sortMode = #name ifTrue: [sizeStr := (parts second findTokens: ' ') third]. - sortMode = #date ifTrue: [sizeStr := (parts first findTokens: ' ') third]. - sortMode = #size ifTrue: [sizeStr := (parts first findTokens: ' ') first]. - fsize := (sizeStr copyWithout: $,) asNumber. - - fsize <= 50000 ifTrue: - [ff := directory oldFileOrNoneNamed: self fullName. - ff ifNil: [^ 'For some reason, this file cannot be read' translated]. - contents := ff contentsOfEntireFile. - brevityState := #fullFile. "don't change till actually read" - ^ contents]. - - "if brevityFlag is true, don't display long files when first selected" - first5000 := directory getOnly: 3500 from: fileName. - contents := 'File ''{1}'' is {2} bytes long. - You may use the ''get'' command to read the entire file. - - Here are the first 3500 characters... - ------------------------------------------ - {3} - ------------------------------------------ - ... end of the first 3500 characters.' translated format: {fileName. sizeStr. first5000}. - brevityState := #briefFile. "don't change till actually read" - ^ contents. - - ! Item was removed: - ----- Method: FileList>>recentDirs (in category 'private') ----- - recentDirs - "Put up a menu and let the user select from the list of recently visited directories." - - | dirName | - RecentDirs isEmpty ifTrue: [^self]. - dirName := UIManager default chooseFrom: RecentDirs values: RecentDirs. - dirName == nil ifTrue: [^self]. - self directory: (FileDirectory on: dirName)! Item was removed: - ----- Method: FileList>>registeredFileReaderClasses (in category 'private') ----- - registeredFileReaderClasses - "return the list of classes that provide file reader services" - - ^ FileServices registeredFileReaderClasses! Item was removed: - ----- Method: FileList>>release (in category 'initialization') ----- - release - - self modelSleep! Item was removed: - ----- Method: FileList>>removeServer (in category 'server list') ----- - removeServer - - | choice names | - self flag: #ViolateNonReferenceToOtherClasses. - names := ServerDirectory serverNames. - choice := UIManager default chooseFrom: names values: names. - choice == nil ifTrue: [^ self]. - ServerDirectory removeServerNamed: choice! Item was removed: - ----- Method: FileList>>renameFile (in category 'file menu action') ----- - renameFile - "Rename the currently selected file" - | newName response | - listIndex = 0 ifTrue: [^ self]. - self okToChange ifFalse: [^ self]. - (response := UIManager default request: 'NewFileName?' translated - initialAnswer: fileName) - isEmpty ifTrue: [^ self]. - newName := response asFileName. - newName = fileName ifTrue: [^ self]. - directory rename: fileName toBe: newName. - self updateFileList. - listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. - listIndex > 0 ifTrue: [fileName := newName]. - self changed: #fileListIndex. - ! Item was removed: - ----- Method: FileList>>resort: (in category 'private') ----- - resort: newMode - "Re-sort the list of files." - | name | - listIndex > 0 ifTrue: [ name := self fileNameFromFormattedItem: (list at: listIndex) ]. - sortMode := newMode. - self pattern: pattern. - name ifNotNil: - [ fileName := name. - listIndex := list findFirst: - [ : item | (self fileNameFromFormattedItem: item) = name ]. - self - changed: #fileListIndex ; - changed: #labelString ]. - listIndex = 0 ifTrue: [ self changed: #contents ]. - self updateButtonRow! Item was removed: - ----- Method: FileList>>rootDirectoryList (in category 'directory tree') ----- - rootDirectoryList - | dirList dir servers | - dir := FileDirectory on: ''. - dirList := dir directoryNames collect:[:each| dir directoryNamed: each].. - dirList isEmpty ifTrue:[dirList := Array with: FileDirectory default]. - servers := ServerDirectory serverNames collect: [ :n | ServerDirectory serverNamed: n]. - "This is so FileListPlus will work on ancient Squeak versions." - servers := servers select:[:each| each respondsTo: #localName]. - ^dirList, servers! Item was removed: - ----- Method: FileList>>selectEncoding (in category 'private') ----- - selectEncoding - - | encodingItems | - encodingItems := OrderedCollection new. - TextConverter allSubclasses do: [:each | | names | - names := each encodingNames. - names notEmpty ifTrue: [ | label | - label := '' writeStream. - names do: [:eachName | label nextPutAll: eachName ] separatedBy: [ label nextPutAll: ', ']. - encodingItems add: {label contents. names first asSymbol}. - ]. - ]. - brevityState := UIManager default - chooseFrom: (encodingItems collect: [:spec| spec first]) - values: (encodingItems collect: [:spec| spec last]). - brevityState ifNil: [brevityState := #needToGetBrief]. - ! Item was removed: - ----- Method: FileList>>selectedPath (in category 'directory tree') ----- - selectedPath - | top here | - top := FileDirectory root. - here := directory. - ^(Array streamContents:[:s| | next | - s nextPut: here. - [next := here containingDirectory. - top pathName = next pathName] whileFalse:[ - s nextPut: next. - here := next. - ]]) reversed.! Item was removed: - ----- Method: FileList>>serviceAddNewDirectory (in category 'own services') ----- - serviceAddNewDirectory - "Answer a service entry characterizing the 'add new directory' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new directory' translatedNoop - selector: #addNewDirectory - description: 'adds a new, empty directory (folder)' translatedNoop! Item was removed: - ----- Method: FileList>>serviceAddNewFile (in category 'own services') ----- - serviceAddNewFile - "Answer a service entry characterizing the 'add new file' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new file' translatedNoop - selector: #addNewFile - description: 'create a new,. empty file, and add it to the current directory.' translatedNoop! Item was removed: - ----- Method: FileList>>serviceAllFileOptions (in category 'own services') ----- - serviceAllFileOptions - - ^ {SimpleServiceEntry - provider: self - label: 'more...' translatedNoop - selector: #offerAllFileOptions - description: 'show all the options available' translatedNoop}! Item was removed: - ----- Method: FileList>>serviceCompressFile (in category 'own services') ----- - serviceCompressFile - "Answer a service for compressing a file" - - ^ SimpleServiceEntry - provider: self - label: 'compress' translatedNoop - selector: #compressFile - description: 'compress file' translatedNoop - buttonLabel: 'compress' translatedNoop! Item was removed: - ----- Method: FileList>>serviceCopyName (in category 'own services') ----- - serviceCopyName - - ^ (SimpleServiceEntry - provider: self - label: 'copy name to clipboard' translatedNoop - selector: #copyName - description:'copy name to clipboard' translatedNoop )! Item was removed: - ----- Method: FileList>>serviceDeleteFile (in category 'own services') ----- - serviceDeleteFile - - ^ (SimpleServiceEntry - provider: self - label: 'delete' translatedNoop - selector: #deleteFile) - description: 'delete the seleted item' translatedNoop! Item was removed: - ----- Method: FileList>>serviceGet (in category 'own services') ----- - serviceGet - "Answer a service for getting the entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'get entire file' translatedNoop - selector: #get - description: 'if the file has only been partially read in, because it is very large, read the entire file in at this time.' translatedNoop)! Item was removed: - ----- Method: FileList>>serviceGetEncodedText (in category 'own services') ----- - serviceGetEncodedText - - ^ (SimpleServiceEntry - provider: self - label: 'view as encoded text' translatedNoop - selector: #getEncodedText - description: 'view as encoded text' translatedNoop) - - ! Item was removed: - ----- Method: FileList>>serviceGetHex (in category 'own services') ----- - serviceGetHex - - ^ (SimpleServiceEntry - provider: self - label: 'view as hex' translatedNoop - selector: #getHex - description: 'view as hex' translatedNoop) - - ! Item was removed: - ----- Method: FileList>>serviceRenameFile (in category 'own services') ----- - serviceRenameFile - - ^ (SimpleServiceEntry - provider: self - label: 'rename' translatedNoop - selector: #renameFile - description: 'rename file' translatedNoop)! Item was removed: - ----- Method: FileList>>serviceSortByDate (in category 'own services') ----- - serviceSortByDate - "Answer a service for sorting by date" - - ^ (SimpleServiceEntry new - provider: self - label: 'by date' translatedNoop - selector: #sortByDate - description: 'sort entries by date' translatedNoop) - extraSelector: #sortingByDate; - buttonLabel: 'date' translatedNoop! Item was removed: - ----- Method: FileList>>serviceSortByName (in category 'own services') ----- - serviceSortByName - "Answer a service for soring by name" - - ^ (SimpleServiceEntry new - provider: self label: 'by name' translatedNoop - selector: #sortByName - description: 'sort entries by name' translatedNoop) - extraSelector: #sortingByName; - buttonLabel: 'name' translatedNoop! Item was removed: - ----- Method: FileList>>serviceSortBySize (in category 'own services') ----- - serviceSortBySize - "Answer a service for sorting by size" - - ^ (SimpleServiceEntry - provider: self - label: 'by size' translatedNoop - selector: #sortBySize - description: 'sort entries by size' translatedNoop) - extraSelector: #sortingBySize; - buttonLabel: 'size' translatedNoop! Item was removed: - ----- Method: FileList>>serviceViewContentsInWorkspace (in category 'own services') ----- - serviceViewContentsInWorkspace - "Answer a service for viewing the contents of a file in a workspace" - - ^ (SimpleServiceEntry provider: self label: 'workspace with contents' translatedNoop - selector: #viewContentsInWorkspace) - description: 'open a new Workspace whose contents are set to the contents of this file' translatedNoop! Item was removed: - ----- Method: FileList>>servicesFileContentsMenu: (in category 'file list menu') ----- - servicesFileContentsMenu: aMenu - "Construct aMenu to have items appropriate for the file browser's code pane, for the unshifted state" - <fileContentsMenuShifted: false> - - fileName ifNotNil: [| services maybeLine extraLines | - services := OrderedCollection new. - (#(briefHex briefFile needToGetBriefHex needToGetBrief) includes: brevityState) ifTrue: - [services add: self serviceGet]. - (#(fullHex briefHex needToGetFullHex needToGetBriefHex) includes: brevityState) ifFalse: - [services add: self serviceGetHex]. - (#(needToGetShiftJIS needToGetEUCJP needToGetCNGB needToGetEUCKR needToGetUTF8) includes: brevityState) ifFalse: - [services add: self serviceGetEncodedText]. - maybeLine := services size. - (FileStream sourceFileSuffixes includes: self suffixOfSelectedFile) ifTrue: - [services addAll: - (self servicesFromSelectorSpecs: - #(fileIntoNewChangeSet: fileIn: browseChangesFile: browseFile:))]. - - extraLines := OrderedCollection new. - maybeLine > 0 ifTrue: [extraLines add: maybeLine]. - services size > maybeLine ifTrue: [extraLines add: services size]. - aMenu - addServices: services - for: self - extraLines: extraLines]. - ^ aMenu - ! Item was removed: - ----- Method: FileList>>servicesFromSelectorSpecs: (in category 'own services') ----- - servicesFromSelectorSpecs: symbolArray - "Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service. Pass the symbol #- along unchanged to serve as a separator between services" - - "FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)" - - | services col | - col := OrderedCollection new. - services := FileServices allRegisteredServices, (self myServicesForFile: #dummy suffix: '*'). - symbolArray do: - [:sel | | res | - sel == #- - ifTrue: - [col add: sel] - ifFalse: - [res := services - detect: [:each | each selector = sel] ifNone: [nil]. - res notNil - ifTrue: [col add: res]]]. - ^ col! Item was removed: - ----- Method: FileList>>servicesVolumeMenu: (in category 'volume menu') ----- - servicesVolumeMenu: aMenu - <volumeMenu> - aMenu - addServices: (self itemsForDirectory: self directory) - for: self - extraLines: #(). - ^aMenu.! Item was removed: - ----- Method: FileList>>setDefaultEncoderFor: (in category 'private') ----- - setDefaultEncoderFor: fileStream - "Based on former #defaultEncoderFor:." - - | l | - l := fileStream fullName asLowercase. - " ((l endsWith: FileStream multiCs) or: [ - l endsWith: FileStream multiSt]) ifTrue: [ - ^ UTF8TextConverter new. - ]. - " - ((l endsWith: FileStream cs) or: [l endsWith: FileStream st]) - ifTrue: [fileStream setConverterForCode] - ifFalse: [fileStream converter: ISO88591TextConverter new].! Item was removed: - ----- Method: FileList>>setDirectoryTo: (in category 'directory tree') ----- - setDirectoryTo: dir - "Set the current directory shown in the FileList. - Does not allow setting the directory to nil since this blows up in various places." - dir ifNil:[^self]. - self directory: dir. - brevityState := #FileList. - self changed: #fileList. - self changed: #contents. - self changed: #pathAndPattern.! Item was removed: - ----- Method: FileList>>setFileStream: (in category 'initialization') ----- - setFileStream: aStream - "Used to initialize a spawned file editor. Sets directory too." - self directory: aStream directory. - fileName := aStream localName. - pattern := '*'. - listIndex := 1. "pretend a file is selected" - aStream close. - brevityState := #needToGetBrief. - self - changed: #contents ; - changed: #labelString! Item was removed: - ----- Method: FileList>>shiftedFileContentsMenu: (in category 'file list menu') ----- - shiftedFileContentsMenu: aMenu - "Delegate the shifted menu to the default shifted menu" - <fileContentsMenuShifted: true> - ^ aMenu addList: self class shiftedYellowButtonMenuItems; yourself - ! Item was removed: - ----- Method: FileList>>sortBlock (in category 'private') ----- - sortBlock - "Answer block to decide what order to display the directory entries." - - ^ [ :x :y | - (x isDirectory = y isDirectory) - ifTrue: [ - "sort by user-specified criterion" - sortMode = #name - ifTrue: [(x name compare: y name) <= 2] - ifFalse: [ sortMode = #date - ifTrue: [ x modificationTime = y modificationTime - ifTrue: [ (x name compare: y name) <= 2 ] - ifFalse: [ x modificationTime > y modificationTime ] ] - ifFalse: [ "size" - x fileSize = y fileSize - ifTrue: [ (x name compare: y name) <= 2 ] - ifFalse: [ x fileSize > y fileSize ] ] ] ] - ifFalse: [ - "directories always precede files" - x isDirectory ] ]! Item was removed: - ----- Method: FileList>>sortByDate (in category 'file menu action') ----- - sortByDate - self resort: #date! Item was removed: - ----- Method: FileList>>sortByName (in category 'file menu action') ----- - sortByName - self resort: #name! Item was removed: - ----- Method: FileList>>sortBySize (in category 'file menu action') ----- - sortBySize - self resort: #size! Item was removed: - ----- Method: FileList>>sortingByDate (in category 'private') ----- - sortingByDate - ^ sortMode == #date! Item was removed: - ----- Method: FileList>>sortingByName (in category 'private') ----- - sortingByName - ^ sortMode == #name! Item was removed: - ----- Method: FileList>>sortingBySize (in category 'private') ----- - sortingBySize - ^ sortMode == #size! Item was removed: - ----- Method: FileList>>spawn: (in category 'file menu action') ----- - spawn: code - "Open a simple Edit window" - - listIndex = 0 ifTrue: [^ self]. - self class openEditorOn: (directory readOnlyFileNamed: fileName) - "read only just for initial look" - editString: code! Item was removed: - ----- Method: FileList>>step (in category 'private') ----- - step - | ext | - brevityState = #graphic ifTrue: [ - ext := self availableGraphicsExtent. - ext = lastGraphicsExtent ifFalse: [ - lastGraphicsExtent := ext. - brevityState := #needToGetGraphic. - self changed: #contents]]! Item was removed: - ----- Method: FileList>>stepTimeIn: (in category 'private') ----- - stepTimeIn: aWindow - ^500! Item was removed: - ----- Method: FileList>>subDirectoriesOf: (in category 'directory tree') ----- - subDirectoriesOf: aDirectory - "provide a list of subdirectory names sorted alphnum-no-case" - - ^(aDirectory directoryNames sorted: [:a :b| (a compare: b) <= 2]) collect:[:each| aDirectory directoryNamed: each].! Item was removed: - ----- Method: FileList>>suffixOfSelectedFile (in category 'file list menu') ----- - suffixOfSelectedFile - "Answer the file extension of the receiver's selected file" - ^ FileServices suffixOf: self fullName.! Item was removed: - ----- Method: FileList>>topConstantHeightFrame:fromLeft:width: (in category 'toolbuilder') ----- - topConstantHeightFrame: height fromLeft: leftFraction width: rightFraction - ^LayoutFrame new - topFraction: 0 offset: 0; - leftFraction: leftFraction offset: 0; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: 0 offset: height; - yourself.! Item was removed: - ----- Method: FileList>>universalButtonServices (in category 'initialization') ----- - universalButtonServices - "Answer a list of services underlying the universal buttons in their initial inception. For the moment, only the sorting buttons are shown." - - ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}! Item was removed: - ----- Method: FileList>>update: (in category 'updating') ----- - update: aParameter - "Receive a change notice from an object of whom the receiver is a dependent" - - (aParameter == #fileListChanged) ifTrue: [self updateFileList]. - super update: aParameter! Item was removed: - ----- Method: FileList>>updateButtonRow (in category 'initialization') ----- - updateButtonRow - "Dynamically update the contents of the button row, if any." - self changed: #getButtonRow.! Item was removed: - ----- Method: FileList>>updateFileList (in category 'private') ----- - updateFileList - "Update my files list with file names in the current directory - that match the pattern. - The pattern string may have embedded newlines or semicolons; these separate different patterns." - | patterns | - patterns := OrderedCollection new. - Cursor wait showWhile: [ - (pattern findTokens: (String with: Character cr with: Character lf with: $;)) - do: [ :each | - (each includes: $*) | (each includes: $#) - ifTrue: [ patterns add: each] - ifFalse: [each isEmpty - ifTrue: [ patterns add: '*'] - ifFalse: [ patterns add: '*' , each , '*']]]. - - list := self listForPatterns: patterns. - listIndex := 0. - volListIndex := volList size. - fileName := nil. - contents := ''. - self changed: #volumeListIndex. - self changed: #fileList. - self updateButtonRow]! Item was removed: - ----- Method: FileList>>veryDeepFixupWith: (in category 'volume list and pattern') ----- - veryDeepFixupWith: deepCopier - super veryDeepFixupWith: deepCopier. - volListIndex := 1. - self directory: FileDirectory default. - self updateFileList! Item was removed: - ----- Method: FileList>>viewContentsInWorkspace (in category 'own services') ----- - viewContentsInWorkspace - "View the contents of my selected file in a new workspace." - - | fileContents workspace lineEndConvention | - fileContents := self directory - readOnlyFileNamed: self fileName - do: [:fileStream | - fileStream - setConverterForCode; - wantsLineEndConversion: true. - lineEndConvention := fileStream detectLineEndConvention. - fileStream contents]. - workspace := (Project uiManager edit: fileContents label: nil shouldStyle: Workspace shouldStyle) model. - - "Remember certain information to allow edits in the same file." - workspace - windowTitle: (self directory localNameFor: self fileName); - fileDirectory: self directory; - fileLineEndConvention: lineEndConvention; - saveContentsInFileOnAccept. - ! Item was removed: - ----- Method: FileList>>volumeList (in category 'volume list and pattern') ----- - volumeList - "Answer the current list of volumes." - - ^ volList - ! Item was removed: - ----- Method: FileList>>volumeListIndex (in category 'volume list and pattern') ----- - volumeListIndex - "Answer the index of the currently selected volume." - - ^ volListIndex - ! Item was removed: - ----- Method: FileList>>volumeListIndex: (in category 'volume list and pattern') ----- - volumeListIndex: index - "Select the volume name having the given index." - - | delim path | - volListIndex := index. - index = 1 - ifTrue: [self directory: (FileDirectory on: '')] - ifFalse: [delim := directory pathNameDelimiter. - path := String streamContents: [:strm | - 2 to: index do: [:i | - strm nextPutAll: (volList at: i) withBlanksTrimmed. - i < index ifTrue: [strm nextPut: delim]]]. - self directory: (FileDirectory on: path)]. - brevityState := #FileList. - self addPath: path. - self changed: #fileList. - self changed: #contents. - self updateButtonRow.! Item was removed: - ----- Method: FileList>>volumeMenu: (in category 'volume menu') ----- - volumeMenu: aMenu - ^ self menu: aMenu for: #(volumeMenu volumeMenuShifted:) - ! Item was removed: - ----- Method: FileList>>wantsDraggedObject: (in category 'drag''n''drop') ----- - wantsDraggedObject: anObject - - ^ anObject class == DirectoryEntryFile! Item was removed: - ----- Method: FileList>>wantsSteps (in category 'private') ----- - wantsSteps - ^true! Item was removed: - FileList subclass: #FileList2 - instanceVariableNames: 'showDirsInFileList currentDirectorySelected fileSelectionBlock dirSelectionBlock optionalButtonSpecs modalView directoryChangeBlock ok' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - FileList2 class - instanceVariableNames: 'lastSelDir'! - - !FileList2 commentStamp: 'BJP 11/19/2003 21:13' prior: 0! - Some variations on FileList that - - use a hierarchical pane to show folder structure - - use different pane combinations, button layouts and prefiltering for specific uses - - FileList2 morphicView openInWorld "an alternative to the standard FileList" - FileList2 morphicViewNoFile openInWorld "useful for selecting, but not viewing" - FileList2 morphicViewProjectLoader openInWorld "useful for finding and loading projects" - FileList2 modalFolderSelector "allows the user to select a folder" - - - - ! - FileList2 class - instanceVariableNames: 'lastSelDir'! Item was removed: - ----- Method: FileList2 class>>addFullPanesTo:from: (in category 'utility') ----- - addFullPanesTo: window from: aCollection - - - - aCollection do: [ :each | | frame | - frame := LayoutFrame - fractions: each second - offsets: each third. - window addMorph: each first fullFrame: frame. - ]! Item was removed: - ----- Method: FileList2 class>>blueButtonText:textColor:color:inWindow: (in category 'blue ui') ----- - blueButtonText: aString textColor: textColor color: aColor inWindow: window - | result | - result := window - fancyText: aString translated - font: Preferences standardEToysFont - color: textColor. - result setProperty: #buttonText toValue: aString; - hResizing: #rigid; - extent: 100 @ 20; - layoutInset: 4; - borderWidth: 1; - useRoundedCorners. - aColor isNil - ifFalse: [""result color: aColor. result borderColor: aColor muchDarker]. - ^ result! Item was removed: - ----- Method: FileList2 class>>blueButtonText:textColor:color:inWindow:balloonText:selector:recipient: (in category 'blue ui') ----- - blueButtonText: aString textColor: textColor color: aColor inWindow: window balloonText: balloonText selector: sel recipient: recip - | result | - result := window - fancyText: aString translated - font: Preferences standardEToysFont - color: textColor. - result setProperty: #buttonText toValue: aString; - hResizing: #rigid; - extent: 100 @ 20; - layoutInset: 4; - borderWidth: 1; - useRoundedCorners; - setBalloonText: balloonText. - result - on: #mouseUp - send: sel - to: recip. - aColor isNil - ifFalse: ["" - result color: aColor. - result borderColor: aColor muchDarker]. - ^ result! Item was removed: - ----- Method: FileList2 class>>blueButtonText:textColor:inWindow: (in category 'blue ui') ----- - blueButtonText: aString textColor: textColor inWindow: window - ^ self - blueButtonText: aString - textColor: textColor - color: nil - inWindow: window! Item was removed: - ----- Method: FileList2 class>>blueButtonText:textColor:inWindow:balloonText:selector:recipient: (in category 'blue ui') ----- - blueButtonText: aString textColor: textColor inWindow: window balloonText: balloonText selector: sel recipient: recip - ^ self - blueButtonText: aString - textColor: textColor - color: nil - inWindow: window - balloonText: balloonText - selector: sel - recipient: recip ! Item was removed: - ----- Method: FileList2 class>>enableTypeButtons:info:forDir: (in category 'blue ui') ----- - enableTypeButtons: typeButtons info: fileTypeInfo forDir: aDirectory - - | foundSuffixes firstEnabled | - - firstEnabled := nil. - foundSuffixes := (aDirectory ifNil: [ #()] ifNotNil: [ aDirectory fileNames]) collect: [ :each | (each findTokens: '.') last asLowercase]. - foundSuffixes := foundSuffixes asSet. - fileTypeInfo with: typeButtons do: [ :info :button | | enableIt fileSuffixes | - fileSuffixes := info second. - enableIt := fileSuffixes anySatisfy: [ :patt | foundSuffixes includes: patt]. - button - setProperty: #enabled - toValue: enableIt. - enableIt ifTrue: [firstEnabled ifNil: [firstEnabled := button]]. - ]. - firstEnabled ifNotNil: [^firstEnabled mouseUp: nil]. - typeButtons do: [ :each | each color: Color gray]. - - ! Item was removed: - ----- Method: FileList2 class>>endingSpecs (in category 'blue ui') ----- - endingSpecs - "Answer a collection of specs to build the selective 'find anything' tool called by the Navigator. This version uses the services registry to do so." - "FileList2 morphicViewGeneralLoaderInWorld: Project current world" - | specs rejects | - rejects := #(addFileToNewZip: compressFile: openInZipViewer: extractAllFrom: openOn:). - specs := OrderedCollection new. - self fileExtensionsByCategory keysAndValuesDo: [:category :extensions | - | services okExtensions | - services := Dictionary new. - okExtensions := Set new. - - extensions do: [:ext | - (FileServices itemsForFile: (FileDirectory default fullPathFor: 'fred.' , ext)) - reject: [:service | rejects includes: service selector] - thenDo: [:service | - services at: service label put: service. - okExtensions add: ext]]. - services isEmpty ifFalse: [ - specs add: { - category. - okExtensions. - services values }]]. - ^ specs! Item was removed: - ----- Method: FileList2 class>>fileExtensionsByCategory (in category 'blue ui') ----- - fileExtensionsByCategory - - ^ OrderedDictionary new - at: 'Art' put: ImageReadWriter allTypicalFileExtensions; - at: 'Morphs' put: #('morph' 'morphs' 'sp'); - at: 'Projects' put: #('extseg' 'project' 'pr'); - at: 'MIDI' put: #('mid' 'midi'); - at: 'Music' put: #('mp3'); - at: 'Movies' put: #('movie' 'mpg' 'mpeg' 'qt' 'mov'); - at: 'Flash' put: #('swf'); - "at: 'Books' put: #('bo'); - at: 'Code' put: #('st' 'cs'); - at: 'TrueType' put: #('ttf'); - at: '3ds' put: #('3ds'); - at: 'Tape' put: #('tape'); - at: 'Wonderland' put: #('wrl'); - at: 'HTML' put: #('htm' 'html');" - yourself! Item was removed: - ----- Method: FileList2 class>>hideSqueakletDirectoryBlock (in category 'blocks') ----- - hideSqueakletDirectoryBlock - ^[:dirName| (dirName sameAs: 'Squeaklets') not]! Item was removed: - ----- Method: FileList2 class>>lastSelDir (in category 'accessing') ----- - lastSelDir - "Return the last selected directory or the default directory if no directory was selected so far." - - ^lastSelDir ifNil: [ lastSelDir := FileDirectory default ]! Item was removed: - ----- Method: FileList2 class>>lastSelDir: (in category 'accessing') ----- - lastSelDir: aFileDirectory - "Store the last selected directory. This will be selected as default in newly opened file or folder selectors" - - ^lastSelDir := aFileDirectory! Item was removed: - ----- Method: FileList2 class>>modalFileSelector (in category 'modal dialogs') ----- - modalFileSelector - - | window | - - window := self morphicViewFileSelector. - window openCenteredInWorld. - UserInterfaceTheme current applyTo: window allMorphs. - self modalLoopOn: window. - ^(window valueOfProperty: #fileListModel) getSelectedFile! Item was removed: - ----- Method: FileList2 class>>modalFileSelectorForSuffixes: (in category 'modal dialogs') ----- - modalFileSelectorForSuffixes: aList - - | window aFileList | - - window := self morphicViewFileSelectorForSuffixes: aList. - aFileList := window valueOfProperty: #fileListModel. - aFileList resort: #name. - window openCenteredInWorld. - UserInterfaceTheme current applyTo: window allMorphs. - self modalLoopOn: window. - ^aFileList getSelectedFile! Item was removed: - ----- Method: FileList2 class>>modalFileSelectorForSuffixes:directory: (in category 'modal dialogs') ----- - modalFileSelectorForSuffixes: aList directory: aDirectory - - | window aFileList | - - window := self morphicViewFileSelectorForSuffixes: aList directory: aDirectory. - aFileList := window valueOfProperty: #fileListModel. - window openCenteredInWorld. - UserInterfaceTheme current applyTo: window allMorphs. - self modalLoopOn: window. - ^aFileList getSelectedFile! Item was removed: - ----- Method: FileList2 class>>modalFolderSelector (in category 'modal dialogs') ----- - modalFolderSelector - - ^self modalFolderSelector: self lastSelDir - ! Item was removed: - ----- Method: FileList2 class>>modalFolderSelector: (in category 'modal dialogs') ----- - modalFolderSelector: aDir - - | window fileModel | - window := self morphicViewFolderSelector: aDir. - fileModel := window model. - window openInWorld: self currentWorld extent: 300 at 400. - UserInterfaceTheme current applyTo: window allMorphs. - self modalLoopOn: window. - ^fileModel getSelectedDirectory withoutListWrapper! Item was removed: - ----- Method: FileList2 class>>modalFolderSelectorForProject: (in category 'modal dialogs') ----- - modalFolderSelectorForProject: aProject - " - FileList2 modalFolderSelectorForProject: Project current - " - "Not currently being converted to FileSaverDialog etc because it implements the decidedly outre looking 'blue ui' Project dialog. " - | window fileModel w | - - window := FileList2 morphicViewProjectSaverFor: aProject. - fileModel := window valueOfProperty: #FileList. - w := self currentWorld. - window position: w topLeft + (w extent - window extent // 2). - w addMorphInLayer: window. - w startSteppingSubmorphsOf: window. - UserInterfaceTheme current applyTo: window allMorphs. - self modalLoopOn: window. - ^fileModel getSelectedDirectory withoutListWrapper! Item was removed: - ----- Method: FileList2 class>>modalFolderSelectorForProjectLoad (in category 'modal dialogs') ----- - modalFolderSelectorForProjectLoad - - | window fileModel w | - - window := self morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false. - fileModel := window valueOfProperty: #FileList. - w := self currentWorld. - window position: w topLeft + (w extent - window extent // 2). - window openInWorld: w. - UserInterfaceTheme current applyTo: window allMorphs. - self modalLoopOn: window. - ^fileModel getSelectedDirectory withoutListWrapper! Item was removed: - ----- Method: FileList2 class>>modalLoopOn: (in category 'utility') ----- - modalLoopOn: aMorph - [aMorph world notNil] whileTrue: [ - aMorph outermostWorldMorph doOneCycle. - ].! Item was removed: - ----- Method: FileList2 class>>morphicView (in category 'morphic ui') ----- - morphicView - ^ self morphicViewOnDirectory: FileDirectory default! Item was removed: - ----- Method: FileList2 class>>morphicViewFileSelector (in category 'morphic ui') ----- - morphicViewFileSelector - - ^self morphicViewFileSelectorForSuffixes: nil - ! Item was removed: - ----- Method: FileList2 class>>morphicViewFileSelectorForSuffixes: (in category 'morphic ui') ----- - morphicViewFileSelectorForSuffixes: aList - "Answer a morphic file-selector tool for the given suffix list." - - ^self morphicViewFileSelectorForSuffixes: aList directory: self lastSelDir! Item was removed: - ----- Method: FileList2 class>>morphicViewFileSelectorForSuffixes:directory: (in category 'morphic ui') ----- - morphicViewFileSelectorForSuffixes: aList directory: dir - "Answer a morphic file-selector tool for the given suffix list and the given directory." - - | aFileList window fixedSize midLine gap | - aFileList := self new directory: dir. - aFileList optionalButtonSpecs: aFileList okayAndCancelServices. - aList ifNotNil: - [aFileList fileSelectionBlock: [:entry :myPattern | - entry isDirectory - ifTrue: - [false] - ifFalse: - [aList includes: (FileDirectory extensionFor: entry name asLowercase)]]]. - window := BorderedMorph new - layoutPolicy: ProportionalLayout new; - color: Color lightBlue; - borderColor: Color blue; - borderWidth: 4; - layoutInset: 4; - extent: 600 at 400; - useRoundedCorners. - window setProperty: #fileListModel toValue: aFileList. - aFileList modalView: window. - midLine := 0.4. - fixedSize := 25. - gap := 5. - self addFullPanesTo: window from: { - {self textRow: 'Please select a file'. 0 @ 0 corner: 1 @ 0. 0 at 0 corner: 0 at fixedSize}. - {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0 at fixedSize corner: 0@(fixedSize * 2)}. - {aFileList morphicDirectoryTreePane. 0 at 0 corner: midLine at 1. - gap @(fixedSize * 2) corner: gap negated at 0}. - {aFileList morphicFileListPane. midLine @ 0 corner: 1 at 1. - gap@(fixedSize * 2) corner: gap negated at 0}. - }. - - aFileList postOpen. - - ^ window ! Item was removed: - ----- Method: FileList2 class>>morphicViewFolderSelector (in category 'morphic ui') ----- - morphicViewFolderSelector - - ^self morphicViewFolderSelector: FileDirectory default! Item was removed: - ----- Method: FileList2 class>>morphicViewFolderSelector: (in category 'morphic ui') ----- - morphicViewFolderSelector: aDir - "Answer a tool that allows the user to select a folder" - - | aFileList window fixedSize | - aFileList := self new directory: aDir. - aFileList optionalButtonSpecs: aFileList servicesForFolderSelector. - window := (SystemWindow labelled: aDir pathName) model: aFileList. - aFileList modalView: window. - - fixedSize := 25. - self addFullPanesTo: window from: { - {self textRow: 'Please select a folder'. 0 @ 0 corner: 1 @ 0. - 0 at 0 corner: 0 at fixedSize}. - {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. - 0 at fixedSize corner: 0@(fixedSize * 2)}. - {aFileList morphicDirectoryTreePane. 0 at 0 corner: 1 at 1. - 0@(fixedSize * 2) corner: 0 at 0}. - }. - aFileList postOpen. - ^ window ! Item was removed: - ----- Method: FileList2 class>>morphicViewGeneralLoaderInWorld: (in category 'blue ui') ----- - morphicViewGeneralLoaderInWorld: aWorld - " - FileList2 morphicViewGeneralLoaderInWorld: self currentWorld - " - | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b fileTypeInfo fileTypeButtons fileTypeRow actionRow | - - fileTypeInfo := self endingSpecs. - window := AlignmentMorphBob1 newColumn. - window hResizing: #shrinkWrap; vResizing: #shrinkWrap. - textColor1 := Color r: 0.742 g: 0.839 b: 1.0. - aFileList := self new directory: FileDirectory default. - aFileList - fileSelectionBlock: self projectOnlySelectionBlock; - modalView: window. - window - setProperty: #FileList toValue: aFileList; - wrapCentering: #center; cellPositioning: #topCenter; - borderWidth: 1; - borderColor: (Color r: 0.9 g: 0.801 b: 0.2); - useRoundedCorners. - - fileTypeButtons := fileTypeInfo collect: [ :each | - (self blueButtonText: each first textColor: Color gray inWindow: window) - setProperty: #enabled toValue: true; - hResizing: #shrinkWrap; - useSquareCorners - ]. - buttons := {{'OK'. Color lightGreen}. {'Cancel'. Color lightRed}} collect: [ :each | - self blueButtonText: each first textColor: textColor1 color: each second inWindow: window - ]. - - treePane := aFileList morphicDirectoryTreePane - extent: 250 at 300; - retractable: false; - borderWidth: 0. - fileListPane := aFileList morphicFileListPane - extent: 350 at 300; - retractable: false; - borderWidth: 0. - window addARow: {window fancyText: 'Find...' translated font: Preferences standardEToysTitleFont color: textColor1}. - fileTypeRow := window addARowCentered: fileTypeButtons cellInset: 2. - actionRow := window addARowCentered: { - buttons first. - (Morph new extent: 30 at 5) color: Color transparent. - buttons second - } cellInset: 2. - window - addARow: { - (window inAColumn: {(pane2a := window inARow: {window inAColumn: {treePane}}) - useRoundedCorners; - layoutInset: 0; - borderWidth: 1; - borderColor: (Color r: 0.6 g: 0.7 b: 1) - }) layoutInset: 10. - (window inAColumn: {(pane2b := window inARow: {window inAColumn: {fileListPane}}) - useRoundedCorners; - layoutInset: 0; - borderWidth: 1; - borderColor: (Color r: 0.6 g: 0.7 b: 1) - }) layoutInset: 10. - }. - window fullBounds. - window fillWithRamp: (Color r: 1 g: 0.85 b: 0.975) oriented: 0.65. - pane2a fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35). - pane2b fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35). - " - buttons do: [ :each | - each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0). - ]. - " - fileTypeButtons do: [ :each | - each - on: #mouseUp - send: #value:value: - to: [ :evt :morph | - self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph. - ] - ]. - buttons first on: #mouseUp send: #okHit to: aFileList. - buttons second on: #mouseUp send: #cancelHit to: aFileList. - aFileList postOpen. - window position: aWorld topLeft + (aWorld extent - window extent // 2). - aFileList directoryChangeBlock: [ :newDir | - self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: nil. - self enableTypeButtons: fileTypeButtons info: fileTypeInfo forDir: newDir. - ]. - aFileList directory: aFileList directory. - window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). - ^ window openInWorld: aWorld.! Item was removed: - ----- Method: FileList2 class>>morphicViewImageViewer (in category 'morphic ui') ----- - morphicViewImageViewer - - | dir aFileList window midLine fixedSize | - - dir := FileDirectory default. - aFileList := self new directory: dir. - aFileList optionalButtonSpecs: aFileList specsForImageViewer. - aFileList fileSelectionBlock: [ :entry :myPattern | - entry isDirectory ifTrue: [ - false - ] ifFalse: [ - #('bmp' 'gif' 'jpg' 'form' 'png') includes: - (FileDirectory extensionFor: entry name asLowercase) - ] - ]. - window := (SystemWindow labelled: dir pathName) model: aFileList. - - fixedSize := 25. - midLine := 0.4. - self addFullPanesTo: window from: { - {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. - 0 at 0 corner: 0 at fixedSize}. - {aFileList morphicDirectoryTreePane. 0 at 0 corner: midLine at 1. - 0 at fixedSize corner: 0 at 0}. - {aFileList morphicFileListPane. midLine @ 0 corner: 1 at 1. - 0 at fixedSize corner: 0 at 0}. - }. - aFileList postOpen. - ^ window ! Item was removed: - ----- Method: FileList2 class>>morphicViewNoFile (in category 'morphic ui') ----- - morphicViewNoFile - - | dir aFileList window midLine fixedSize | - - dir := FileDirectory default. - aFileList := self new directory: dir. - window := (SystemWindow labelled: dir pathName) model: aFileList. - - fixedSize := 25. - midLine := 0.4. - self addFullPanesTo: window from: { - {aFileList morphicPatternPane. 0 at 0 corner: 0.3 at 0. 0 at 0 corner: 0 at fixedSize}. - {aFileList optionalButtonRow. 0.3 @ 0 corner: 1 at 0. 0 at 0 corner: 0 at fixedSize}. - {aFileList morphicDirectoryTreePane. 0 at 0 corner: midLine at 1. 0 at fixedSize corner: 0 at 0}. - {aFileList morphicFileListPane. midLine @ 0 corner: 1 at 1. 0 at fixedSize corner: 0 at 0}. - }. - aFileList postOpen. - ^ window ! Item was removed: - ----- Method: FileList2 class>>morphicViewProjectLoader (in category 'morphic ui') ----- - morphicViewProjectLoader - - | dir aFileList window midLine fixedSize | - - dir := FileDirectory default. - aFileList := self new directory: dir. - aFileList optionalButtonSpecs: aFileList servicesForProjectLoader. - aFileList fileSelectionBlock: self projectOnlySelectionBlock. - window := (SystemWindow labelled: dir pathName) model: aFileList. - - fixedSize := 25. - midLine := 0.4. - self addFullPanesTo: window from: { - {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0 at 0 corner: 0 at fixedSize}. - {aFileList morphicDirectoryTreePane. 0 at 0 corner: midLine at 1. 0 at fixedSize corner: 0 at 0}. - {aFileList morphicFileListPane. midLine @ 0 corner: 1 at 1. 0 at fixedSize corner: 0 at 0}. - }. - aFileList postOpen. - ^ window ! Item was removed: - ----- Method: FileList2 class>>morphicViewProjectLoader2InWorld: (in category 'blue ui') ----- - morphicViewProjectLoader2InWorld: aWorld - - ^self morphicViewProjectLoader2InWorld: aWorld reallyLoad: true! Item was removed: - ----- Method: FileList2 class>>morphicViewProjectLoader2InWorld:reallyLoad: (in category 'blue ui') ----- - morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean - - ^self - morphicViewProjectLoader2InWorld: aWorld - reallyLoad: aBoolean - dirFilterType: #initialDirectoryList - ! Item was removed: - ----- Method: FileList2 class>>morphicViewProjectLoader2InWorld:reallyLoad:dirFilterType: (in category 'blue ui') ----- - morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean dirFilterType: aSymbol - - | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b treeExtent filesExtent | - - window := AlignmentMorphBob1 newColumn. - window hResizing: #shrinkWrap; vResizing: #shrinkWrap. - textColor1 := Color r: 0.742 g: 0.839 b: 1.0. - aFileList := self new. - aFileList - optionalButtonSpecs: aFileList servicesForProjectLoader; - fileSelectionBlock: ( - aSymbol == #limitedSuperSwikiDirectoryList ifTrue: [ - MessageSend receiver: Project current selector: #latestProjectVersionsFromFileEntries: - ] ifFalse: [ - self projectOnlySelectionBlock - ] - ); - "dirSelectionBlock: self hideSqueakletDirectoryBlock;" - modalView: window. - aFileList directory: FileDirectory default. - window - setProperty: #FileList toValue: aFileList; - wrapCentering: #center; cellPositioning: #topCenter; - borderWidth: 1; - borderColor: (Color r: 0.9 g: 0.801 b: 0.2); - useRoundedCorners. - buttons := {{'OK'. Color lightGreen}. {'Cancel'. Color lightRed}} collect: [ :each | - self blueButtonText: each first textColor: textColor1 color: each second inWindow: window - ]. - - aWorld width < 800 ifTrue: [ - treeExtent := 150 at 300. - filesExtent := 350 at 300. - ] ifFalse: [ - treeExtent := 350 at 500. - filesExtent := 550 at 500. - ]. - (treePane := aFileList morphicDirectoryTreePaneFiltered: aSymbol) - extent: treeExtent; - retractable: false; - borderWidth: 0. - fileListPane := aFileList morphicFileListPane - extent: filesExtent; - retractable: false; - borderWidth: 0. - window - addARow: { - window fancyText: 'Load A Project' translated font: Preferences standardEToysTitleFont color: textColor1 - }; - addARowCentered: { - buttons first. - (Morph new extent: 30 at 5) color: Color transparent. - buttons second - }; - addARow: { - window fancyText: 'Please select a project' translated font: Preferences standardEToysFont color: textColor1 - }; - addARow: { - (window inAColumn: {(pane2a := window inARow: {window inAColumn: {treePane}}) - useRoundedCorners; - layoutInset: 0; - borderWidth: 1; - borderColor: (Color r: 0.6 g: 0.7 b: 1) - }) layoutInset: 10. - (window inAColumn: {(pane2b := window inARow: {window inAColumn: {fileListPane}}) - useRoundedCorners; - layoutInset: 0; - borderWidth: 1; - borderColor: (Color r: 0.6 g: 0.7 b: 1) - }) layoutInset: 10. - }. - window fullBounds. - window fillWithRamp: (Color r: 1 g: 0.85 b: 0.975) oriented: 0.65. - pane2a fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35). - pane2b fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35). - " - buttons do: [ :each | - each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0). - ]. - " - buttons first - on: #mouseUp - send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit]) - to: aFileList. - buttons second on: #mouseUp send: #cancelHit to: aFileList. - aFileList postOpen. - window position: aWorld topLeft + (aWorld extent - window extent // 2). - window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). - ^ window openInWorld: aWorld.! Item was removed: - ----- Method: FileList2 class>>morphicViewProjectSaverFor: (in category 'blue ui') ----- - morphicViewProjectSaverFor: aProject - " - (FileList2 morphicViewProjectSaverFor: Project current) openInWorld - " - | window aFileList buttons treePane pane2 textColor1 option treeExtent buttonData buttonRow | - - textColor1 := Color r: 0.742 g: 0.839 b: 1.0. - aFileList := self new directory: ServerDirectory projectDefaultDirectory. - aFileList dirSelectionBlock: self hideSqueakletDirectoryBlock. - window := AlignmentMorphBob1 newColumn. - window hResizing: #shrinkWrap; vResizing: #shrinkWrap. - aFileList modalView: window. - window - setProperty: #FileList toValue: aFileList; - wrapCentering: #center; cellPositioning: #topCenter; - borderWidth: 1; - borderColor: (Color r: 0.9 g: 0.801 b: 0.2); - useRoundedCorners. - - buttonData := Preferences enableLocalSave - ifTrue: [{ - {'Save'. #okHit. 'Save in the place specified below, and in the Squeaklets folder on your local disk'. Color lightGreen}. - {'Save on local disk only'. #saveLocalOnlyHit. 'saves in the Squeaklets folder'. Color lightGreen}. - {'Cancel'. #cancelHit. 'return without saving'. Color lightRed} - }] - ifFalse: [{ - {'Save'. #okHit. 'Save in the place specified below, and in the Squeaklets folder on your local disk'. Color lightGreen}. - {'Cancel'. #cancelHit. 'return without saving'. Color lightRed} - }]. - buttons := buttonData collect: [ :each | - (self blueButtonText: each first textColor: textColor1 color: each fourth inWindow: window) - setBalloonText: each third translated; - hResizing: #shrinkWrap; - on: #mouseUp send: each second to: aFileList - ]. - - option := aProject world - valueOfProperty: #SuperSwikiPublishOptions - ifAbsent: [#initialDirectoryList]. - aProject world removeProperty: #SuperSwikiPublishOptions. - - treeExtent := Project current world height < 500 - ifTrue: [ 350 at 150 ] - ifFalse: [ 350 at 300 ]. - - (treePane := aFileList morphicDirectoryTreePaneFiltered: option) - extent: treeExtent; - retractable: false; - borderWidth: 0. - window - addARowCentered: { - window fancyText: 'Publish This Project' translated font: Preferences standardEToysTitleFont color: textColor1 - }. - buttonRow := OrderedCollection new. - buttons do: [:button | buttonRow add: button] separatedBy: [buttonRow add: ((Morph new extent: 30 at 5) color: Color transparent)]. - - " addARowCentered: { - buttons first. - (Morph new extent: 30 at 5) color: Color transparent. - buttons second. - (Morph new extent: 30 at 5) color: Color transparent. - buttons third - };" - window - addARowCentered: buttonRow; - addARowCentered: { (window inAColumn: {(ProjectViewMorph on: aProject) lock}) layoutInset: 4}; - addARowCentered: { - window fancyText: 'Please select a folder' translated font: Preferences standardEToysFont color: textColor1 - }; - addARow: { - ( - window inAColumn: { - (pane2 := window inARow: {window inAColumn: {treePane}}) - useRoundedCorners; - layoutInset: 0; - borderWidth: 1; - borderColor: (Color r: 0.6 g: 0.7 b: 1) - } - ) layoutInset: 10 - }. - window fullBounds. - window fillWithRamp: (Color r: 1 g: 0.85 b: 0.975) oriented: 0.65. - pane2 fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35). - " - buttons do: [ :each | - each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0). - ]. - " - window morphicLayerNumber: window class dialogLayer. - aFileList postOpen. - window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). - ^ window ! Item was removed: - ----- Method: FileList2 class>>openMorphicViewInWorld (in category 'instance creation') ----- - openMorphicViewInWorld - "FileList2 openMorphicViewInWorld" - ^self morphicView openInWorld! Item was removed: - ----- Method: FileList2 class>>projectOnlySelectionBlock (in category 'blocks') ----- - projectOnlySelectionBlock - - ^[ :entry :myPattern | - entry isDirectory ifTrue: [ - false - ] ifFalse: [ - #('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name] - ] - ]! Item was removed: - ----- Method: FileList2 class>>prototypicalToolWindow (in category 'instance creation') ----- - prototypicalToolWindow - "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" - - ^ self morphicView applyModelExtent! Item was removed: - ----- Method: FileList2 class>>selectionBlockForSuffixes: (in category 'blocks') ----- - selectionBlockForSuffixes: anArray - - ^[ :entry :myPattern | - entry isDirectory ifTrue: [ - false - ] ifFalse: [ - anArray anySatisfy: [ :each | each match: entry name] - ] - ]! Item was removed: - ----- Method: FileList2 class>>textRow: (in category 'utility') ----- - textRow: aString - - ^AlignmentMorph newRow - wrapCentering: #center; cellPositioning: #leftCenter; - color: Color transparent; - layoutInset: 0; - addMorph: ( - AlignmentMorph newColumn - wrapCentering: #center; cellPositioning: #topCenter; - color: Color transparent; - vResizing: #shrinkWrap; - layoutInset: 0; - addMorph: ( - AlignmentMorph newRow - wrapCentering: #center; cellPositioning: #leftCenter; - color: Color transparent; - hResizing: #shrinkWrap; - vResizing: #shrinkWrap; - layoutInset: 0; - addMorph: ((StringMorph contents: aString) color: ((UserInterfaceTheme current get: #textColor for: #PluggableTextMorph) ifNil: [Color black])) asMorph - ) - )! Item was removed: - ----- Method: FileList2 class>>update:in:fileTypeRow:morphUp: (in category 'morphic ui') ----- - update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph - - | fileTypeInfo info2 buttons textColor1 fileSuffixes fileActions aFileList fileTypeString | - (morph notNil and: [(morph valueOfProperty: #enabled) not]) ifTrue: [^ self]. - - fileTypeRow submorphsDo: [:sub | - sub color: ( - sub == morph - ifTrue: [Color white] - ifFalse: [(sub valueOfProperty: #enabled) - ifTrue: [Color transparent] - ifFalse: [Color gray]])]. - fileTypeString := morph isNil - ifTrue: ['xxxx'] - ifFalse: [morph valueOfProperty: #buttonText]. - - aFileList := window valueOfProperty: #FileList. - textColor1 := Color r: 0.742 g: 0.839 b: 1.0. - actionRow removeAllMorphs. - fileTypeInfo := self endingSpecs. - info2 := fileTypeInfo - detect: [:each | each first = fileTypeString] - ifNone: [nil]. - info2 - ifNil: [ - buttons := OrderedCollection new] - ifNotNil: [ - fileSuffixes := info2 second. - fileActions := info2 third. - buttons := fileActions - collect: [ :each | aFileList blueButtonForService: each textColor: textColor1 inWindow: window ] - as: OrderedCollection. - buttons do: [ :each | - each fillWithRamp: Color lightGreen oriented: (0.75 @ 0)]]. - buttons addLast: (self - blueButtonText: 'Cancel' - textColor: textColor1 - color: Color lightRed - inWindow: window - balloonText: 'Cancel this search' - selector: #cancelHit - recipient: aFileList). - buttons do: [:each | actionRow addMorphBack: each]. - window fullBounds. - fileSuffixes ifNotNil: [ - aFileList fileSelectionBlock: ( - self selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each]))]. - aFileList updateFileList.! Item was removed: - ----- Method: FileList2>>addNewDirectory (in category 'own services') ----- - addNewDirectory - super addNewDirectory. - self updateDirectory.! Item was removed: - ----- Method: FileList2>>blueButtonForService:textColor:inWindow: (in category 'user interface') ----- - blueButtonForService: aService textColor: textColor inWindow: window - | block result | - block := [self fullName isNil - ifTrue: [self inform: 'Please select a file' translated] - ifFalse: [aService performServiceFor: self]]. - result := window - fancyText: aService buttonLabel capitalized translated - font: Preferences standardEToysFont - color: textColor. - result setProperty: #buttonText toValue: aService buttonLabel capitalized; - hResizing: #rigid; - extent: 100 @ 20; - layoutInset: 4; - borderWidth: 1; - useRoundedCorners; - setBalloonText: aService label. - result - on: #mouseUp - send: #value - to: block. - ^ result! Item was removed: - ----- Method: FileList2>>cancelHit (in category 'private') ----- - cancelHit - - modalView delete. - directory := fileName := currentDirectorySelected := nil.! Item was removed: - ----- Method: FileList2>>changeDirectoryTo: (in category 'volume list and pattern') ----- - changeDirectoryTo: aFileDirectory - "Change directory as requested." - - self directory: aFileDirectory. - self updateDirectory! Item was removed: - ----- Method: FileList2>>currentDirectorySelected (in category 'private') ----- - currentDirectorySelected - ^ currentDirectorySelected - ! Item was removed: - ----- Method: FileList2>>deleteDirectory (in category 'own services') ----- - deleteDirectory - super deleteDirectory. - self updateDirectory.! Item was removed: - ----- Method: FileList2>>dirSelectionBlock: (in category 'initialization') ----- - dirSelectionBlock: aBlock - dirSelectionBlock := aBlock! Item was removed: - ----- Method: FileList2>>directory (in category 'volume list and pattern') ----- - directory - - ^directory! Item was removed: - ----- Method: FileList2>>directory: (in category 'initialization') ----- - directory: dir - "Set the path of the volume to be displayed." - - self okToChange ifFalse: [^ self]. - - self modelSleep. - directory := dir. - self modelWakeUp. - - sortMode == nil ifTrue: [sortMode := #date]. - volList := Array with: '[]'. - directory ifNotNil: [ - volList := volList, directory pathParts. "Nesting suggestion from RvL" - ]. - volList := volList withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each]. - self changed: #relabel. - self changed: #volumeList. - self pattern: pattern. - directoryChangeBlock ifNotNil: [directoryChangeBlock value: directory].! Item was removed: - ----- Method: FileList2>>directoryChangeBlock: (in category 'initialization') ----- - directoryChangeBlock: aBlockOrNil - - directoryChangeBlock := aBlockOrNil.! Item was removed: - ----- Method: FileList2>>directoryNamesFor: (in category 'private') ----- - directoryNamesFor: item - "item may be file directory or server directory" - | entries | - entries := item directoryNames. - dirSelectionBlock ifNotNil:[entries := entries select: dirSelectionBlock]. - ^entries! Item was removed: - ----- Method: FileList2>>fileSelectionBlock: (in category 'initialization') ----- - fileSelectionBlock: aBlock - - fileSelectionBlock := aBlock! Item was removed: - ----- Method: FileList2>>getSelectedDirectory (in category 'private') ----- - getSelectedDirectory - ok == true ifFalse: [^ nil]. - ^ currentDirectorySelected - ! Item was removed: - ----- Method: FileList2>>getSelectedFile (in category 'private') ----- - getSelectedFile - "Answer a filestream on the selected file. If it cannot be opened for read/write, try read-only before giving up; answer nil if unsuccessful" - - ok == true ifFalse: [^ nil]. - directory ifNil: [^ nil]. - fileName ifNil: [^ nil]. - ^ (directory oldFileNamed: fileName) ifNil: - [directory readOnlyFileNamed: fileName]! Item was removed: - ----- Method: FileList2>>importImage (in category 'own services') ----- - importImage - "Import the given image file and store the resulting Form in the default Imports" - - | fname image | - fname := fileName sansPeriodSuffix. - image := Form fromFileNamed: self fullName. - Imports default importImage: image named: fname. - ! Item was removed: - ----- Method: FileList2>>initialDirectoryList (in category 'initialization') ----- - initialDirectoryList - - | dirList | - dirList := (FileDirectory on: '') directoryNames collect: [ :each | - FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self]. - dirList isEmpty ifTrue:[ - dirList := Array with: (FileDirectoryWrapper - with: FileDirectory default - name: FileDirectory default localName - model: self)]. - dirList := dirList,( - ServerDirectory serverNames collect: [ :n | | nameToShow dir | - dir := ServerDirectory serverNamed: n. - nameToShow := n. - (dir directoryWrapperClass with: dir name: nameToShow model: self) - balloonText: dir realUrl - ] - ). - ^dirList! Item was removed: - ----- Method: FileList2>>initialize (in category 'initialize-release') ----- - initialize - - super initialize. - showDirsInFileList := false. - fileSelectionBlock := [ :entry :myPattern | - entry isDirectory ifTrue: [ - showDirsInFileList - ] ifFalse: [ - myPattern = '*' or: [myPattern match: entry name] - ] - ]. - dirSelectionBlock := [ :dirName | true].! Item was removed: - ----- Method: FileList2>>isDirectoryList: (in category 'drag''n''drop') ----- - isDirectoryList: aMorph - ^aMorph isKindOf: SimpleHierarchicalListMorph! Item was removed: - ----- Method: FileList2>>labelString (in category 'initialization') ----- - labelString - ^ (directory ifNil: [^'[]']) pathName contractTo: 50! Item was removed: - ----- Method: FileList2>>limitedSuperSwikiDirectoryList (in category 'initialization') ----- - limitedSuperSwikiDirectoryList - - | dirList localDirName localDir | - - dirList := OrderedCollection new. - ServerDirectory serverNames do: [ :n | | dir nameToShow | - dir := ServerDirectory serverNamed: n. - dir isProjectSwiki ifTrue: [ - nameToShow := n. - dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self) - balloonText: dir realUrl) - ]. - ]. - ServerDirectory localProjectDirectories do: [ :each | - dirList add: (FileDirectoryWrapper with: each name: each localName model: self) - ]. - "Make sure the following are always shown, but not twice" - localDirName := SecurityManager default untrustedUserDirectory. - localDir := FileDirectory on: localDirName. - ((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName) - ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)]. - FileDirectory default pathName = localDirName - ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)]. - (dirList anySatisfy: [:each | each withoutListWrapper acceptsUploads]) - ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)]. - ^dirList! Item was removed: - ----- Method: FileList2>>limitedSuperSwikiPublishDirectoryList (in category 'initialization') ----- - limitedSuperSwikiPublishDirectoryList - - | dirList localDirName localDir | - - dirList := self publishingServers. - ServerDirectory localProjectDirectories do: [ :each | - dirList add: (FileDirectoryWrapper with: each name: each localName model: self)]. - - "Make sure the following are always shown, but not twice" - localDirName := SecurityManager default untrustedUserDirectory. - localDir := FileDirectory on: localDirName. - ((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName) - ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)]. - FileDirectory default pathName = localDirName - ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)]. - ^dirList! Item was removed: - ----- Method: FileList2>>listForPattern: (in category 'volume list and pattern') ----- - listForPattern: pat - "Make the list be those file names which match the pattern." - - | sizePad newList entries | - directory ifNil: [^#()]. - entries := (Preferences eToyLoginEnabled - and: [Utilities authorNamePerSe notNil]) - ifTrue: [directory matchingEntries: {'submittedBy: ' , Utilities authorName.} ] - ifFalse: [directory entries]. - (fileSelectionBlock isKindOf: MessageSend) ifTrue: [ - fileSelectionBlock arguments: {entries}. - newList := fileSelectionBlock value. - fileSelectionBlock arguments: #(). - ] ifFalse: [ - newList := entries select: [:entry | fileSelectionBlock value: entry value: pat]. - ]. - newList := newList asArray sort: self sortBlock. - sizePad := (newList inject: 0 into: [:mx :entry | mx max: entry fileSize]) - asStringWithCommas size - 1. - ^newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]! Item was removed: - ----- Method: FileList2>>listForPatterns: (in category 'volume list and pattern') ----- - listForPatterns: anArray - "Make the list be those file names which match the patterns." - - | sizePad newList | - directory ifNil: [^#()]. - (fileSelectionBlock isKindOf: MessageSend) ifTrue: [ - fileSelectionBlock arguments: {directory entries}. - newList := fileSelectionBlock value. - fileSelectionBlock arguments: #(). - ] ifFalse: [ - newList := Set new. - anArray do: [ :pat | - newList addAll: (directory entries select: [:entry | fileSelectionBlock value: entry value: pat]) ]. - ]. - newList := newList asArray sort: self sortBlock. - sizePad := (newList inject: 0 into: [:mx :entry | mx max: entry fileSize]) - asStringWithCommas size. - ^newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]! Item was removed: - ----- Method: FileList2>>modalView: (in category 'private') ----- - modalView: aSystemWindowOrSuch - - modalView := aSystemWindowOrSuch! Item was removed: - ----- Method: FileList2>>morphicDirectoryTreePane (in category 'user interface') ----- - morphicDirectoryTreePane - - ^self morphicDirectoryTreePaneFiltered: #initialDirectoryList - ! Item was removed: - ----- Method: FileList2>>morphicDirectoryTreePaneFiltered: (in category 'user interface') ----- - morphicDirectoryTreePaneFiltered: aSymbol - ^(SimpleHierarchicalListMorph - on: self - list: aSymbol - selected: #currentDirectorySelected - changeSelected: #setSelectedDirectoryTo: - menu: #volumeMenu: - keystroke: nil) - autoDeselect: false; - enableDrag: false; - enableDrop: true; - yourself - - ! Item was removed: - ----- Method: FileList2>>morphicFileContentsPane (in category 'user interface') ----- - morphicFileContentsPane - - ^PluggableTextMorph - on: self - text: #contents - accept: #put: - readSelection: #contentsSelection - menu: #fileContentsMenu:shifted: - ! Item was removed: - ----- Method: FileList2>>morphicFileListPane (in category 'user interface') ----- - morphicFileListPane - - ^(PluggableListMorph - on: self - list: #fileList - selected: #fileListIndex - changeSelected: #fileListIndex: - menu: #fileListMenu:) - enableDrag: true; - enableDrop: false; - yourself - - ! Item was removed: - ----- Method: FileList2>>morphicPatternPane (in category 'user interface') ----- - morphicPatternPane - | pane | - pane := PluggableTextMorph - on: self - text: #pattern - accept: #pattern:. - pane acceptOnCR: true. - ^pane - - ! Item was removed: - ----- Method: FileList2>>okHit (in category 'private') ----- - okHit - - ok := true. - currentDirectorySelected - ifNil: [ Beeper beep ] - ifNotNil: [ - self class lastSelDir: directory. - modalView delete ]! Item was removed: - ----- Method: FileList2>>okHitForProjectLoader (in category 'private') ----- - okHitForProjectLoader - - | areaOfProgress | - fileName ifNil: [^ self]. - ok := true. - areaOfProgress := modalView firstSubmorph. - [ - areaOfProgress setProperty: #deleteOnProgressCompletion toValue: modalView. - self openProjectFromFile. - modalView delete. "probably won't get here" - ] - on: ProgressTargetRequestNotification - do: [ :ex | ex resume: areaOfProgress]. - - - ! Item was removed: - ----- Method: FileList2>>okayAndCancelServices (in category 'own services') ----- - okayAndCancelServices - "Answer ok and cancel services" - - ^ {self serviceOkay. self serviceCancel}! Item was removed: - ----- Method: FileList2>>openImageInWindow (in category 'own services') ----- - openImageInWindow - "Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP. - Fail if file format is not recognized." - - | image myStream | - myStream := (directory readOnlyFileNamed: fileName) binary. - [image := Form fromBinaryStream: myStream. - Project current openImage: image name: fileName saveResource: false] - ensure: [myStream close] - ! Item was removed: - ----- Method: FileList2>>openProjectFromFile (in category 'own services') ----- - openProjectFromFile - "Reconstitute a Morph from the selected file, presumed to be represent - a Morph saved via the SmartRefStream mechanism, and open it in an - appropriate Morphic world." - - Project canWeLoadAProjectNow ifFalse: [^ self]. - ProjectViewMorph - openFromDirectory: directory - andFileName: fileName - ! Item was removed: - ----- Method: FileList2>>optionalButtonRow (in category 'initialization') ----- - optionalButtonRow - "Answer the button row associated with a file list" - - | aRow | - aRow := AlignmentMorph newRow beSticky. - aRow color: Color transparent. - aRow clipSubmorphs: true. - aRow layoutInset: 5 at 1; cellGap: 6. - self universalButtonServices do: "just the three sort-by items" - [:service | - aRow addMorphBack: (service buttonToTriggerIn: self). - (service selector == #sortBySize) - ifTrue: - [aRow addTransparentSpacerOfSize: (4 at 0)]]. - aRow setNameTo: 'buttons'. - aRow setProperty: #buttonRow toValue: true. "Used for dynamic retrieval later on" - ^ aRow! Item was removed: - ----- Method: FileList2>>optionalButtonSpecs (in category 'initialization') ----- - optionalButtonSpecs - - ^optionalButtonSpecs ifNil: [super optionalButtonSpecs]! Item was removed: - ----- Method: FileList2>>optionalButtonSpecs: (in category 'initialization') ----- - optionalButtonSpecs: anArray - - optionalButtonSpecs := anArray! Item was removed: - ----- Method: FileList2>>postOpen (in category 'private') ----- - postOpen - - directory ifNotNil: [ - self changed: #(openPath) , directory pathParts. - ]. - ! Item was removed: - ----- Method: FileList2>>publishingServers (in category 'initialization') ----- - publishingServers - - | dirList | - - dirList := OrderedCollection new. - ServerDirectory serverNames do: [ :n | | dir nameToShow | - dir := ServerDirectory serverNamed: n. - (dir isProjectSwiki and: [dir acceptsUploads]) - ifTrue: [ - nameToShow := n. - dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self) - balloonText: dir realUrl)]]. - ^dirList! Item was removed: - ----- Method: FileList2>>removeLinefeeds (in category 'own services') ----- - removeLinefeeds - "Remove any line feeds by converting to CRs instead. This is a temporary implementation for 3.6 only... should be removed during 3.7alpha." - | fileContents | - fileContents := ((FileStream readOnlyFileNamed: self fullName) wantsLineEndConversion: true) contentsOfEntireFile. - (FileStream newFileNamed: self fullName) - nextPutAll: fileContents; - close.! Item was removed: - ----- Method: FileList2>>saveLocalOnlyHit (in category 'private') ----- - saveLocalOnlyHit - ok := true. - modalView delete. - directory := fileName := nil. - currentDirectorySelected := #localOnly.! Item was removed: - ----- Method: FileList2>>serviceCancel (in category 'own services') ----- - serviceCancel - "Answer a service for hitting the cancel button" - - ^ (SimpleServiceEntry new - provider: self - label: 'cancel' translatedNoop - selector: #cancelHit - description: 'hit here to cancel ' translatedNoop) - buttonLabel: 'cancel' translatedNoop! Item was removed: - ----- Method: FileList2>>serviceOkay (in category 'own services') ----- - serviceOkay - "Answer a service for hitting the okay button" - - ^ (SimpleServiceEntry new - provider: self - label: 'okay' translatedNoop - selector: #okHit - description: 'hit here to accept the current selection' translatedNoop) - buttonLabel: 'ok' translatedNoop! Item was removed: - ----- Method: FileList2>>serviceOpenProjectFromFile (in category 'own services') ----- - serviceOpenProjectFromFile - "Answer a service for opening a .pr project file" - - ^ SimpleServiceEntry - provider: self - label: 'load as project' translatedNoop - selector: #openProjectFromFile - description: 'open project from file' translatedNoop - buttonLabel: 'load' translatedNoop! Item was removed: - ----- Method: FileList2>>servicesForFolderSelector (in category 'own services') ----- - servicesForFolderSelector - "Answer the ok and cancel servies for the folder selector" - - ^ self okayAndCancelServices! Item was removed: - ----- Method: FileList2>>servicesForProjectLoader (in category 'own services') ----- - servicesForProjectLoader - "Answer the services to show in the button pane for the project loader" - - ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize. self serviceOpenProjectFromFile}! Item was removed: - ----- Method: FileList2>>setSelectedDirectoryTo: (in category 'private') ----- - setSelectedDirectoryTo: aFileDirectoryWrapper - currentDirectorySelected := aFileDirectoryWrapper. - self directory: aFileDirectoryWrapper withoutListWrapper. - brevityState := #FileList. - "self addPath: path." - self changed: #fileList. - self changed: #contents. - self changed: #currentDirectorySelected.! Item was removed: - ----- Method: FileList2>>specsForImageViewer (in category 'user interface') ----- - specsForImageViewer - - ^{self serviceSortByName. self serviceSortByDate. self serviceSortBySize }! Item was removed: - ----- Method: FileList2>>universalButtonServices (in category 'initialization') ----- - universalButtonServices - "Answer the services to be reflected in the receiver's buttons" - - ^ self optionalButtonSpecs! Item was removed: - ----- Method: FileList2>>updateDirectory (in category 'initialization') ----- - updateDirectory - "directory has been changed externally, by calling directory:. - Now change the view to reflect the change." - self changed: #currentDirectorySelected. - self postOpen.! Item was removed: - ----- Method: FileStream class>>edit: (in category '*Tools-Changes') ----- - edit: fullNameOrStream - - ^ (fullNameOrStream isString - ifTrue: [self fileNamed: fullNameOrStream] - ifFalse: [fullNameOrStream]) edit! Item was removed: - ----- Method: FileStream class>>serviceEditFile (in category '*Tools-Changes') ----- - serviceEditFile - - ^ SimpleServiceEntry - provider: self - label: 'edit as text file' - selector: #edit: - description: 'edit as text file' - buttonLabel: 'edit'! Item was removed: - ----- Method: FileStream class>>serviceEditFileSuffixes (in category '*Tools-Changes') ----- - serviceEditFileSuffixes - - ^ #('*')! Item was removed: - ----- Method: FileStream>>edit (in category '*Tools-Changes') ----- - edit - "Create and schedule an editor on this file." - - FileList openEditorOn: self editString: nil. - ! Item was removed: - ----- Method: FileStream>>fileIntoNewChangeSet (in category '*Tools-Changes') ----- - fileIntoNewChangeSet - "File all of my contents into a new change set." - - self readOnly. - ChangesOrganizer newChangesFromStream: self named: self localName! Item was removed: - ----- Method: Form>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - - ^ FormInspector! Item was removed: - Inspector subclass: #FormInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! Item was removed: - ----- Method: FormInspector>>embedForm:inText: (in category 'support') ----- - embedForm: aForm inText: stringOrText - - ^ stringOrText asText - , ((' (hash: {1})' translated format: {aForm bits hash}) - flag: #workaround "ct: Currently, text equality ignores attributes. Add a hash of the form's bits to the text to ensure that it will be re-rendered in Morphic inspectors. In the long term, we should redefine Text >> #= instead. See: http://lists.squeakfoundation.org/pipermail/squeak-dev/2020-September/211358.html"; - yourself) - , String cr - , (Text string: ' ' attribute: - (TextFontReference toFont: - (FormSetFont new - fromFormArray: (Array with: (aForm copy offset: 0 at 0)) - asciiStart: Character space asInteger - ascent: aForm height)))! Item was removed: - ----- Method: FormInspector>>fieldPixels (in category 'fields') ----- - fieldPixels - - ^ (self newFieldForType: #misc key: #pixels) - name: 'pixels' translated; emphasizeName; - printValueAsIs; - valueGetter: [:form | self embedForm: form inText: form printString]; - yourself! Item was removed: - ----- Method: FormInspector>>streamBaseFieldsOn: (in category 'fields - streaming') ----- - streamBaseFieldsOn: aStream - - super streamBaseFieldsOn: aStream. - aStream nextPut: self fieldPixels.! Item was removed: - ----- Method: FutureMaker>>defaultLabelForInspector (in category '*Tools-Inspector') ----- - defaultLabelForInspector - "Answer the default label to be used for an Inspector window on the receiver." - ^self class name! Item was removed: - ----- Method: FutureMaker>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^ Inspector! Item was removed: - ----- Method: HashedCollection>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Dictionary'! Item was removed: - Browser subclass: #HierarchyBrowser - instanceVariableNames: 'classDisplayList centralClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !HierarchyBrowser commentStamp: 'fbs 3/9/2011 12:02' prior: 0! - I provide facilities to explore classes in the context of their subclass hierarchy. - - My classDisplayList instvar uses indentation to show the subclassing relationship between the displayed classes. - ! Item was removed: - ----- Method: HierarchyBrowser class>>openBrowser (in category 'instance creation') ----- - openBrowser - "Open a default hierarchy browser on Object - ie the entire class tree, so it may take a moment - with class/protocol/message lists" - "HierarchyBrowser openBrowser" - | newBrowser | - newBrowser := self new initHierarchyForClass: Object. - ^ newBrowser buildAndOpenBrowserLabel: nil - ! Item was removed: - ----- Method: HierarchyBrowser>>allAncestorsOfClass:withLevelDo: (in category 'hierarchy - classes') ----- - allAncestorsOfClass: class withLevelDo: classAndLevelBlock - - self - allAncestorsOfClass: class - withLevelDo: classAndLevelBlock - startingLevel: 1.! Item was removed: - ----- Method: HierarchyBrowser>>allAncestorsOfClass:withLevelDo:startingLevel: (in category 'hierarchy - classes') ----- - allAncestorsOfClass: class withLevelDo: classAndLevelBlock startingLevel: level - - (class superclass ifNil: [#()] ifNotNil: [:c | {c}]), class traits - do: [:ancestor | - ancestor isTrait - ifTrue: [ - self - allAncestorsOfTrait: ancestor - withLevelDo: classAndLevelBlock - startingLevel: level + 1] - ifFalse: [ - self - allAncestorsOfClass: ancestor - withLevelDo: classAndLevelBlock - startingLevel: level + 1]. - classAndLevelBlock value: ancestor value: level].! Item was removed: - ----- Method: HierarchyBrowser>>allAncestorsOfTrait:withLevelDo: (in category 'hierarchy - traits') ----- - allAncestorsOfTrait: trait withLevelDo: traitAndLevelBlock - - self - allAncestorsOfTrait: trait - withLevelDo: traitAndLevelBlock - startingLevel: 1.! Item was removed: - ----- Method: HierarchyBrowser>>allAncestorsOfTrait:withLevelDo:startingLevel: (in category 'hierarchy - traits') ----- - allAncestorsOfTrait: trait withLevelDo: traitAndLevelBlock startingLevel: level - - trait traitComposition asTraitComposition traits - do: [:ancestor | - self - allAncestorsOfTrait: ancestor - withLevelDo: traitAndLevelBlock - startingLevel: level + 1. - traitAndLevelBlock value: ancestor value: level].! Item was removed: - ----- Method: HierarchyBrowser>>allSuccessorsOfClass:withLevelDo:startingLevel: (in category 'hierarchy - classes') ----- - allSuccessorsOfClass: class withLevelDo: classAndLevelBlock startingLevel: level - - classAndLevelBlock value: class value: level. - (class subclasses sorted: #name ascending) - do: [:successor | - self - allSuccessorsOfClass: successor - withLevelDo: classAndLevelBlock - startingLevel: level + 1].! Item was removed: - ----- Method: HierarchyBrowser>>allSuccessorsOfTrait:withLevelDo:startingLevel: (in category 'hierarchy - traits') ----- - allSuccessorsOfTrait: trait withLevelDo: traitAndLevelBlock startingLevel: level - - traitAndLevelBlock value: trait value: level. - (trait users "includes classes and traits" sorted: #name ascending) - do: [:user | - self - allSuccessorsOfTrait: user - withLevelDo: traitAndLevelBlock - startingLevel: level + 1].! Item was removed: - ----- Method: HierarchyBrowser>>buildAndOpenBrowserLabel: (in category 'toolbuilder') ----- - buildAndOpenBrowserLabel: aLabelString - "assemble the spec for a class list/hierarchy browser, build it and open it" - - | builder window | - builder := ToolBuilder default. - - window := self buildDefaultBrowserWith: builder. - aLabelString ifNotNil: [:str | window label: str]. - - builder open: window.! Item was removed: - ----- Method: HierarchyBrowser>>buildClassBrowserEditString: (in category 'menu messages') ----- - buildClassBrowserEditString: aString - "Open a hierarchy browser on the currently selected class; the string has to be ignored in this case" - - self spawnHierarchy! Item was removed: - ----- Method: HierarchyBrowser>>buildDefaultBrowserWith: (in category 'toolbuilder') ----- - buildDefaultBrowserWith: builder - "assemble the spec for a hierarchical browser, build it and return the built but not opened morph" - "this build-but-don't-open phase is factored out to support the prototypicalToolWindow facility" - - | max windowSpec | - - - self setupIfNotInitialisedYet. - max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4]. - - windowSpec := self buildWindowWith: builder specs: { - (self classListFrame: max fromTop: 0 fromLeft: 0 width: 0.333) -> [self buildClassListWith: builder]. - (self switchesFrame: max fromLeft: 0 width: 0.333) -> [self buildSwitchesWith: builder]. - (LayoutFrame fractions: (0.333 at 0 corner: 0.666 at max) offsets: (0 at 0 corner: 0 at 0)) -> [self buildMessageCategoryListWith: builder]. - (LayoutFrame fractions: (0.666 at 0 corner: 1 at max) offsets: (0 at 0 corner: 0 at 0)) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - self setMultiWindowFor:windowSpec. - windowSpec defaultFocus: #classList. - - ^builder build: windowSpec! Item was removed: - ----- Method: HierarchyBrowser>>classList (in category 'class list') ----- - classList - "each time we update the class list make sure to check that all the classes we think we should display are in fact in the environment" - classDisplayList := classDisplayList select: [:each | (self environment valueOf: each withBlanksTrimmed asSymbol) notNil]. - ^ classDisplayList! Item was removed: - ----- Method: HierarchyBrowser>>classListIndex: (in category 'initialization') ----- - classListIndex: newIndex - "Cause system organization to reflect appropriate category" - | newClassName ind | - newIndex ~= 0 ifTrue: - [newClassName := (classDisplayList at: newIndex) copyWithout: $ . - selectedSystemCategory := (systemOrganizer categories at: - (systemOrganizer numberOfCategoryOfElement: newClassName) - ifAbsent: [nil])]. - ind := super classListIndex: newIndex. - - "What I'd like to write:" - "self selectedClassName ifNotNil: - [ selectedSystemCategory := self selectedClass category ]." - self changed: #systemCategorySingleton. - ^ ind! Item was removed: - ----- Method: HierarchyBrowser>>copyClass (in category 'class functions') ----- - copyClass - - super copyClass. - self updateAfterClassChange.! Item was removed: - ----- Method: HierarchyBrowser>>defaultBrowserTitle (in category 'initialization') ----- - defaultBrowserTitle - ^ self selectedSystemCategoryName ifNil: [ 'Hierarchy Browser' ]! Item was removed: - ----- Method: HierarchyBrowser>>defineClass:notifying: (in category 'hierarchy - classes') ----- - defineClass: defString notifying: aController - - super defineClass: defString notifying: aController. - self updateAfterClassChange.! Item was removed: - ----- Method: HierarchyBrowser>>defineTrait:notifying: (in category 'hierarchy - traits') ----- - defineTrait: defString notifying: aController - - super defineTrait: defString notifying: aController. - self updateAfterClassChange.! Item was removed: - ----- Method: HierarchyBrowser>>initHierarchyFor: (in category 'initialization') ----- - initHierarchyFor: classOrTrait - - classOrTrait isTrait - ifTrue: [self initHierarchyForTrait: classOrTrait] - ifFalse: [self initHierarchyForClass: classOrTrait].! Item was removed: - ----- Method: HierarchyBrowser>>initHierarchyForClass: (in category 'hierarchy - classes') ----- - initHierarchyForClass: aClassOrMetaClass - - | nonMetaClass baseLevel | - centralClass := aClassOrMetaClass. - nonMetaClass := aClassOrMetaClass theNonMetaClass. - self selectEnvironment: aClassOrMetaClass environment. - metaClassIndicated := aClassOrMetaClass isMeta. - classDisplayList := OrderedCollection new. - baseLevel := 0. - self - allAncestorsOfClass: nonMetaClass - withLevelDo: [ : each : level | baseLevel := baseLevel max: level ]. - self - allAncestorsOfClass: nonMetaClass - withLevelDo: - [ : classOrTrait : level | | label | - label := (String streamContents: - [:stream | baseLevel - level timesRepeat: [ stream nextPutAll: ' ' ]. - stream nextPutAll: classOrTrait name ]). - classOrTrait isTrait - ifTrue: [ label := label asText addAttribute: TextEmphasis italic ]. - classDisplayList add: label ]. - self - allSuccessorsOfClass: nonMetaClass - withLevelDo: - [ : each : level | classDisplayList add: - (String streamContents: - [ : stream | level timesRepeat: [ stream nextPutAll: ' ' ]. - stream nextPutAll: each name ]) ] - startingLevel: baseLevel. - - self changed: #classList. - self selectClass: nonMetaClass.! Item was removed: - ----- Method: HierarchyBrowser>>initHierarchyForTrait: (in category 'hierarchy - traits') ----- - initHierarchyForTrait: baseTraitOrClassTrait - - | baseTrait baseLevel | - centralClass := baseTraitOrClassTrait. - baseTrait := baseTraitOrClassTrait baseTrait. - self selectEnvironment: baseTraitOrClassTrait environment. - metaClassIndicated := baseTraitOrClassTrait isClassTrait. - classDisplayList := OrderedCollection new. - baseLevel := 0. - self - allAncestorsOfTrait: baseTrait - withLevelDo: [ : each : level | baseLevel := baseLevel max: level ]. - self - allAncestorsOfTrait: baseTrait - withLevelDo: - [:each :level | classDisplayList add: - (String streamContents: - [ : stream | baseLevel - level timesRepeat: [ stream nextPutAll: ' ' ]. - stream nextPutAll: each name ]) ]. - self - allSuccessorsOfTrait: baseTrait - withLevelDo: - [:classOrTrait :level | | label | - label := (String streamContents: - [ : stream | level timesRepeat: [ stream nextPutAll: ' ' ]. - stream nextPutAll: classOrTrait name ]). - classOrTrait isTrait - ifFalse: [ label := label asText addAttribute: TextEmphasis italic ]. - classDisplayList add: label ] - startingLevel: baseLevel. - - self changed: #classList. - self selectClass: baseTrait.! Item was removed: - ----- Method: HierarchyBrowser>>isHierarchy (in category 'multi-window support') ----- - isHierarchy - "This almost certainly needs implementing in ClassListBrowser to return false" - ^true! Item was removed: - ----- Method: HierarchyBrowser>>postAcceptBrowseFor: (in category 'morphic ui') ----- - postAcceptBrowseFor: aHierarchyBrowser - (aHierarchyBrowser selectedClass ~= self selectedClass or: [ aHierarchyBrowser selectedMessageName notNil ]) ifTrue: [ self selectMessageCategoryNamed: nil ]. - aHierarchyBrowser instanceMessagesIndicated - ifTrue: [ self indicateInstanceMessages ] - ifFalse: [ self indicateClassMessages ]. - self - selectClass: aHierarchyBrowser selectedClass ; - selectedMessageName: aHierarchyBrowser selectedMessageName ; - showHomeCategory! Item was removed: - ----- Method: HierarchyBrowser>>removeSystemCategory (in category 'menu messages') ----- - removeSystemCategory - "If a class category is selected, create a Confirmer so the user can - verify that the currently selected class category and all of its classes - should be removed from the system. If so, remove it." - - self inform: 'Use a normal Browser, in which you can see - the entire category you are trying to remove.'! Item was removed: - ----- Method: HierarchyBrowser>>renameClass (in category 'class functions') ----- - renameClass - - super renameClass. - self updateAfterClassChange.! Item was removed: - ----- Method: HierarchyBrowser>>representsSameBrowseeAs: (in category 'morphic ui') ----- - representsSameBrowseeAs: anotherModel - ^ self hasUnacceptedEdits not - and: [ classDisplayList size = anotherModel classList size - and: [ classDisplayList includesAllOf: anotherModel classList ] ]! Item was removed: - ----- Method: HierarchyBrowser>>selectClassNamed: (in category 'initialization') ----- - selectClassNamed: aSymbolOrString - | newClassName | - newClassName := aSymbolOrString ifNotNil: [ aSymbolOrString asSymbol ]. - selectedSystemCategory := (systemOrganizer categories at: - (systemOrganizer numberOfCategoryOfElement: newClassName) ifAbsent: [ nil ]). - - super selectClassNamed: newClassName. - self changed: #systemCategorySingleton. - - ^ newClassName.! Item was removed: - ----- Method: HierarchyBrowser>>selectedClassName (in category 'initialization') ----- - selectedClassName - "Answer the name of the class currently selected. di - bug fix for the case where name cannot be found -- return nil rather than halt" - - | aName | - aName := super selectedClassName. - aName ifNil: [ ^ nil ]. - ^ (aName copyWithout: Character space) asSymbol! Item was removed: - ----- Method: HierarchyBrowser>>setClass: (in category 'initialization') ----- - setClass: aClassOrTrait - self initHierarchyFor: (centralClass ifNil: [ aClassOrTrait ]). - super setClass: aClassOrTrait! Item was removed: - ----- Method: HierarchyBrowser>>setupIfNotInitialisedYet (in category 'toolbuilder') ----- - setupIfNotInitialisedYet - "HierarchyBrowser needs some initialisation to work in the ToolBuilder>build: world since there has to be a list of classes ready to be listed. As a default we use the full Object class tree" - classDisplayList ifNil:[ self initHierarchyForClass: Object]! Item was removed: - ----- Method: HierarchyBrowser>>spawnOrNavigateTo: (in category 'private') ----- - spawnOrNavigateTo: aClass - (aClass inheritsFrom: centralClass) - ifTrue: [ super spawnOrNavigateTo: aClass ] - ifFalse: [ self systemNavigation browseHierarchy: aClass ]! Item was removed: - ----- Method: HierarchyBrowser>>systemCatSingletonKey:from: (in category 'menu messages') ----- - systemCatSingletonKey: aChar from: aView - "This appears to be obsolete now that the hierarchybrowser has not category view" - ^ self systemCatListKey: aChar from: aView! Item was removed: - ----- Method: HierarchyBrowser>>systemCatSingletonMenu: (in category 'menu messages') ----- - systemCatSingletonMenu: aMenu - "This appears to be obsolete now that the hierarchybrowser has not category view" - ^ aMenu labels: - 'find class... (f) - browse - printOut - fileOut - update - rename... - remove' - lines: #(1 4) - selections: - #(findClass buildSystemCategoryBrowser - printOutSystemCategory fileOutSystemCategory updateSystemCategories - renameSystemCategory removeSystemCategory ) - ! Item was removed: - ----- Method: HierarchyBrowser>>systemCategorySingleton (in category 'initialization') ----- - systemCategorySingleton - - | cls | - cls := self selectedClass. - ^ cls ifNil: [Array new] - ifNotNil: [Array with: cls category]! Item was removed: - ----- Method: HierarchyBrowser>>updateAfterClassChange (in category 'initialization') ----- - updateAfterClassChange - "It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser." - - | priorSelection | - priorSelection := self selectedClassName. - - (centralClass notNil and: [centralClass isObsolete not]) - ifTrue: [self initHierarchyFor: centralClass]. - - (self classListIndexOf: priorSelection) > 0 - ifTrue: [self selectClassNamed: priorSelection].! Item was removed: - StringHolder subclass: #Inspector - instanceVariableNames: 'object context fields customFields selectionIndex expression contentsTyped fieldListStyler shouldStyleValuePane selectionUpdateTime' - classVariableNames: 'CachedAllInstVarsLabel CurrentLocale' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !Inspector commentStamp: 'mt 4/6/2020 15:16' prior: 0! - I am a tool that allows to inspect and modify the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected inspector field, which may be an instance variable, of the observed object. - - Beside the #contents in my value pane, I have an extra code pane that holds an #expression to be evaluated on the inspected object -- not the currently selected inspector field. - - Take a look at my "fields ..." protocols as well as InspectorField. - - (Note that the idea of "elements" from the CollectionInspector bleeds a little bit down into this interface to simplify the implementation of field truncation as well as #inspectOne. Sorry for that. Usually, the inspected object will only produce "fields" to display, and maybe "items" in a pop-up menu. Only collections have "elements".)! Item was removed: - ----- Method: Inspector class>>inspect: (in category 'instance creation') ----- - inspect: anObject - "Answer a new (sub)instance of me to provide an inspector for anObject." - - ^ self new inspect: anObject! Item was removed: - ----- Method: Inspector class>>on: (in category 'instance creation') ----- - on: anObject - "Answer a new instance of me to provide an inspector for anObject." - - ^ self new object: anObject! Item was removed: - ----- Method: Inspector class>>openOn: (in category 'instance creation') ----- - openOn: anObject - "Open an inspector for anObject." - - ^ ToolBuilder open: (self on: anObject)! Item was removed: - ----- Method: Inspector class>>openOn:withLabel: (in category 'instance creation') ----- - openOn: anObject withLabel: label - "Open an inspector with a specific label. Use this to set the inspector into context to explain why that object is inspected." - - ^ ToolBuilder open: (self on: anObject) label: label! Item was removed: - ----- Method: Inspector>>aboutToStyle:requestor: (in category 'user interface - styling') ----- - aboutToStyle: aStyler requestor: anObject - "We have two text fields in this tool: code pane and value pane. Do always style the code pane." - - self updateStyler: aStyler requestor: anObject. - - ^ (anObject knownName = #valuePane) - ==> [shouldStyleValuePane == true - "Fields can override styling so that contents are always styled." - or: [self selectedField notNil ==> [self selectedField shouldStyleValue]]]! Item was removed: - ----- Method: Inspector>>addClassItemsTo: (in category 'menu - construction') ----- - addClassItemsTo: aMenu - - aMenu addTranslatedList: #( - - - ('browse full (b)' browseClass) - ('browse hierarchy (h)' browseClassHierarchy) - ('browse protocol (p)' browseFullProtocol)). - - self typeOfSelection = #self ifFalse: [^ self]. - - aMenu addTranslatedList: #( - - - ('references... (r)' browseVariableReferences) - ('assignments... (a)' browseVariableAssignments) - ('class refs (N)' browseClassRefs)).! Item was removed: - ----- Method: Inspector>>addCollectionItemsTo: (in category 'menu - construction') ----- - addCollectionItemsTo: aMenu - - aMenu - add: 'inspect element...' translated - target: self - selector: #inspectOne.! Item was removed: - ----- Method: Inspector>>addCustomField (in category 'fields - custom') ----- - addCustomField - - ^ self addCustomField: (self requestCustomFieldOrCancel: [^ self])! Item was removed: - ----- Method: Inspector>>addCustomField: (in category 'fields - custom') ----- - addCustomField: aField - - aField type: #custom. - self customFields add: aField. - self updateFields. - self selectField: aField.! Item was removed: - ----- Method: Inspector>>addEtoysItemsTo: (in category 'menu - construction') ----- - addEtoysItemsTo: aMenu - - aMenu addLine; addTranslatedList: { - { 'tile for this value (t)'. [self selectionOrObject tearOffTile] }. - { 'viewer for this value (v)'. [self selectionOrObject beViewed] }}.! Item was removed: - ----- Method: Inspector>>addFieldItemsTo: (in category 'menu - construction') ----- - addFieldItemsTo: aMenu - - aMenu addTranslatedList: #( - - - ('copy name (c)' copyName) - ('copy expression' copyExpression 'Copy a code snippet that returns the field''s value when evaluated on the inspected object.')).! Item was removed: - ----- Method: Inspector>>addInstVarItemsTo: (in category 'menu - construction') ----- - addInstVarItemsTo: aMenu - - aMenu addTranslatedList: #( - - - ('references (r)' browseVariableReferences) - ('assignments (a)' browseVariableAssignments)).! Item was removed: - ----- Method: Inspector>>addObjectItemsTo: (in category 'menu - construction') ----- - addObjectItemsTo: aMenu - "The following menu items trigger actions appropricate to all kinds of objects." - - self typeOfSelection = #ellipsis ifTrue: [^ self]. - - aMenu addTranslatedList: { - {'inspect (i)'. #inspectSelection}. - {'explore (I)'. #exploreSelection}. - {'basic inspect'. #inspectSelectionBasic. - 'Inspect all instvars of the object, regardless of\any possible specialized Inspector for this type' withCRs}}. - - aMenu addTranslatedList: { - #-. - {'inspect pointers'. #objectReferencesToSelection. 'objects pointing to this value'}. - {'chase pointers'. #chaseSelectionPointers}. - {'explore pointers'. #exploreSelectionPointers} }.! Item was removed: - ----- Method: Inspector>>allInstVarsTranslated (in category 'private') ----- - allInstVarsTranslated - "Alas translation is slow enough that we notice the slow down in trying to step in the debugger..." - (CurrentLocale ~= Locale current - or: [CachedAllInstVarsLabel isNil]) ifTrue: - [CurrentLocale := Locale current. - CachedAllInstVarsLabel := 'all inst vars' translated]. - ^CachedAllInstVarsLabel! Item was removed: - ----- Method: Inspector>>applyUserInterfaceTheme (in category 'user interface') ----- - applyUserInterfaceTheme - - super applyUserInterfaceTheme. - - self fieldListStyler ifNotNil: [:styler | - styler reset. - self updateFieldList].! Item was removed: - ----- Method: Inspector>>browseClass (in category 'menu - commands') ----- - browseClass - "Open a full browser on the class of the selected item" - - ^ ToolSet browseClass: self classOfSelection! Item was removed: - ----- Method: Inspector>>browseClassHierarchy (in category 'menu - commands') ----- - browseClassHierarchy - "Open a class list browser on the receiver's hierarchy." - - ^ self systemNavigation browseHierarchy: self classOfSelection! Item was removed: - ----- Method: Inspector>>browseVariableAssignments (in category 'menu - commands') ----- - browseVariableAssignments - - ^ self selectedInstVarName - ifNotNil: [:instVar | self systemNavigation - browseAllStoresInto: instVar - from: self object class] - ifNil: [self systemNavigation browseVariableAssignments: self object class]! Item was removed: - ----- Method: Inspector>>browseVariableReferences (in category 'menu - commands') ----- - browseVariableReferences - - ^ self selectedInstVarName - ifNotNil: [:instVar | self systemNavigation - browseAllAccessesTo: instVar - from: self object class] - ifNil: [self systemNavigation browseVariableReferences: self object class]! Item was removed: - ----- Method: Inspector>>buildCodePaneWith: (in category 'toolbuilder') ----- - buildCodePaneWith: builder - "Overridden. Note that I do not hold #contents in my code pane. See my value pane for that." - - ^ builder pluggableCodePaneSpec new - model: self; - getText: #expression; - editText: #expression:; - help: 'Evaluate expressions on inspected object' translated; - menu: #codePaneMenu:shifted:; - askBeforeDiscardingEdits: false; - yourself! Item was removed: - ----- Method: Inspector>>buildExploreButtonWith: (in category 'toolbuilder') ----- - buildExploreButtonWith: builder - - ^ builder pluggableButtonSpec new - model: self; - label: 'explore' translated; - action: #replaceInspectorWithExplorer; - help: 'Switch to an explorer tool' translated; - yourself! Item was removed: - ----- Method: Inspector>>buildFieldListWith: (in category 'toolbuilder') ----- - buildFieldListWith: builder - - ^ builder pluggableListSpec new - model: self; - list: #fieldList; - getIndex: #selectionIndex; - setIndex: #selectionIndex:; - autoDeselect: true; - menu: #fieldListMenu:shifted:; - dragItem: #dragFromFieldList:; - dropItem: #dropOnFieldList:at:shouldCopy:; - keyPress: #inspectorKey:from:; - yourself! Item was removed: - ----- Method: Inspector>>buildValuePaneWith: (in category 'toolbuilder') ----- - buildValuePaneWith: builder - "The value pane holds this StringHolder's contents." - - ^ builder pluggableCodePaneSpec new - model: self; - name: #valuePane; - getText: #contents; - setText: #contents:notifying:; - editText: #typeValue:; "Turn on code styling as you type." - help: 'Selected field''s value' translated; - menu: #codePaneMenu:shifted:; "Share the menu with the code pane." - yourself! Item was removed: - ----- Method: Inspector>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "Inspector openOn: SystemOrganization" - - | windowSpec buttonOffset | - buttonOffset := (Preferences standardButtonFont widthOfString: 'explore') * 3/2. - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 0.3 at 0.71) - -> [self buildFieldListWith: builder]. - (0.3 at 0.0 corner: 1 at 0.71) - -> [self buildValuePaneWith: builder]. - (LayoutFrame fractions: (0 at 0.71 corner: 1 at 1) offsets: (0 at 0 corner: buttonOffset negated at 0)) - -> [self buildCodePaneWith: builder]. - (LayoutFrame fractions: (1 at 0.71 corner: 1 at 1) offsets: (buttonOffset negated at 0 corner: 0 @ 0)) - -> [self buildExploreButtonWith: builder]. - }. - ^ builder build: windowSpec! Item was removed: - ----- Method: Inspector>>chaseSelectionPointers (in category 'menu - commands') ----- - chaseSelectionPointers - - | selected saved | - self hasSelection ifFalse: [^ self changed: #flash]. - selected := self selectionOrObject. - saved := self object. - self object: nil. - ^ [(selected respondsTo: #chasePointers) - flag: #ct "Do we indeed need to isolate Tools-Inspector and Tools-Debugger?"; - flag: #ct "ToolSet"; - ifTrue: [selected chasePointers] - ifFalse: [selected inspectPointers]] - ensure: [self object: saved]! Item was removed: - ----- Method: Inspector>>classOfSelection (in category 'selection - convenience') ----- - classOfSelection - "Answer the class of the receiver's current selection" - - ^ self selectionOrObject class! Item was removed: - ----- Method: Inspector>>contents:notifying: (in category 'accessing - contents') ----- - contents: aString notifying: aController - "Try to change the contents of the selected field. This is the usual callback for all string holders." - - | result | - result := self object class evaluatorClass new - evaluate: aString - in: self doItContext - to: self doItReceiver - notifying: aController - ifFail: [^ false]. - - ^ self replaceSelectionValue: result! Item was removed: - ----- Method: Inspector>>contentsForErrorDoing: (in category 'fields - error handling') ----- - contentsForErrorDoing: aBlock - - ^ 'An error occurred while inspecting this object. {1} to debug the error.' - translated asText format: { - Text - string: 'Click here' translated - attributes: { TextEmphasis bold. PluggableTextAttribute evalBlock: aBlock }}! Item was removed: - ----- Method: Inspector>>contentsForTruncationOf: (in category 'fields - truncation') ----- - contentsForTruncationOf: truncatedKeys - - ^ ('<Fields named {1} to {2} are not shown. {3} to inspect one of those fields or select "inspect element" from the field list menu.>' translated asText - addAttribute: TextEmphasis italic; - format: { - truncatedKeys first storeString. - truncatedKeys last storeString. - 'Click here' translated asText - addAttribute: (PluggableTextAttribute evalBlock: [self inspectOneOf: truncatedKeys]); - yourself. })! Item was removed: - ----- Method: Inspector>>contentsTyped (in category 'accessing - contents') ----- - contentsTyped - - ^ contentsTyped! Item was removed: - ----- Method: Inspector>>contentsTyped: (in category 'accessing - contents') ----- - contentsTyped: aStringOrText - - contentsTyped := aStringOrText.! Item was removed: - ----- Method: Inspector>>context (in category 'accessing') ----- - context - - ^ context! Item was removed: - ----- Method: Inspector>>context: (in category 'accessing') ----- - context: ctxt - "Set the context of inspection, which is used for syntax highlighting and code evaluation." - - context := ctxt.! Item was removed: - ----- Method: Inspector>>copyExpression (in category 'menu - commands') ----- - copyExpression - "From the selected field, copy the code expression that returns the contents of the value pane into the clipboard." - - (self expressionForField: self selectedField) - ifNil: [self error: 'Cannot determine field expression' translated] - ifNotNil: [:fieldExpression | Clipboard clipboardText: fieldExpression].! Item was removed: - ----- Method: Inspector>>copyName (in category 'menu - commands') ----- - copyName - "Copy the name of the selected field into clipboard." - - self selectedFieldName - ifNil: [self error: 'Cannot determine field name.' translated] - ifNotNil: [:name | Clipboard clipboardText: name].! Item was removed: - ----- Method: Inspector>>customFields (in category 'accessing') ----- - customFields - - ^ customFields! Item was removed: - ----- Method: Inspector>>defaultIntegerBase (in category 'user interface') ----- - defaultIntegerBase - "Answer the default base in which to print integers. - Defer to the class of the instance." - - ^ (self object class respondsTo: #defaultIntegerBaseInDebugger) - ifTrue: [self object class perform: #defaultIntegerBaseInDebugger] - ifFalse: [10]! Item was removed: - ----- Method: Inspector>>doItContext (in category 'accessing') ----- - doItContext - "Answer the context in which a text selection can be evaluated." - - ^ self context! Item was removed: - ----- Method: Inspector>>doItReceiver (in category 'accessing') ----- - doItReceiver - "Answer the object that should be informed of the result of evaluating a text selection." - - ^ self object! Item was removed: - ----- Method: Inspector>>dragFromFieldList: (in category 'fields - drag and drop') ----- - dragFromFieldList: index - - ^ (self fields at: index ifAbsent: [nil]) - ifNotNil: [:fieldToDrag | fieldToDrag rememberInspector]! Item was removed: - ----- Method: Inspector>>dropOnFieldList:at:shouldCopy: (in category 'fields - drag and drop') ----- - dropOnFieldList: anObjectOrField at: index shouldCopy: shouldCopyField - "Drop an object to change a field's value or drop a field to add it to the list of custom fields." - - (shouldCopyField and: [anObjectOrField isKindOf: self fieldClass]) - ifTrue: [ - self flag: #refactor. "mt: Instead of abusing #shouldCopy, write a separate hook for dropping fields between list items to insert fields." - self addCustomField: anObjectOrField forgetInspector copy] - ifFalse: [ - self selectionIndex: index. - self replaceSelectionValue: anObjectOrField value].! Item was removed: - ----- Method: Inspector>>elementAt: (in category 'private - collections') ----- - elementAt: indexOrKey - "Backstop to simplify #inspectOne for all kinds of inspectors." - - ^ (self elementGetterAt: indexOrKey) value: self object! Item was removed: - ----- Method: Inspector>>elementGetterAt: (in category 'private - collections') ----- - elementGetterAt: indexOrKey - "Backstop to simplify #inspectOne for all kinds of inspectors." - - ^ [:object | object basicAt: indexOrKey]! Item was removed: - ----- Method: Inspector>>emphasizeError: (in category 'fields - error handling') ----- - emphasizeError: errorMessage - - ^ ('<{1}>' asText format: { errorMessage }) - addAttribute: self textColorForError; - yourself! Item was removed: - ----- Method: Inspector>>ensureSelectedField (in category 'selection') ----- - ensureSelectedField - "If there is no field selected, try to select the first one." - - self hasSelection - ifFalse: [self selectionIndex: 1]. - - ^ self selectedField! Item was removed: - ----- Method: Inspector>>exploreSelection (in category 'menu - commands') ----- - exploreSelection - - ^ self selectionOrObject explore! Item was removed: - ----- Method: Inspector>>exploreSelectionPointers (in category 'menu - commands') ----- - exploreSelectionPointers - - ^ self selectionOrObject explorePointers! Item was removed: - ----- Method: Inspector>>expression (in category 'accessing - contents') ----- - expression - "The code string in the code pane. Recorded for Inspector/Explorer switching. See #replaceInspectorWithExplorer." - - ^ expression ifNil: ['']! Item was removed: - ----- Method: Inspector>>expression: (in category 'accessing - contents') ----- - expression: aStringOrText - "The code string in the code pane. Recorded for Inspector/Explorer switching. See #replaceInspectorWithExplorer." - - expression := aStringOrText.! Item was removed: - ----- Method: Inspector>>expressionForField: (in category 'fields') ----- - expressionForField: anInspectorField - "Subclasses can override this to configure the way to retrieve the source-code expression for the field." - - ^ anInspectorField valueGetterExpression! Item was removed: - ----- Method: Inspector>>fieldAllInstVars (in category 'fields') ----- - fieldAllInstVars - - ^ (self newFieldForType: #all key: #allInstVars) - name: self allInstVarsTranslated; emphasizeName; - valueGetter: [:obj | obj longPrintString]; printValueAsIs; - yourself! Item was removed: - ----- Method: Inspector>>fieldClass (in category 'initialization') ----- - fieldClass - - ^ InspectorField! Item was removed: - ----- Method: Inspector>>fieldList (in category 'user interface') ----- - fieldList - "Return a list of texts that identify the fields for the object under inspection so that the user can make an informed decision on what to inspect." - - ^ self fieldListStyler - ifNil: [self fields collect: [:field | field name]] - ifNotNil: [:styler | - self updateStyler: styler. - self fields collect: [:field | - field shouldStyleName - ifTrue: [styler styledTextFor: field name asText] - ifFalse: [field name]]]! Item was removed: - ----- Method: Inspector>>fieldListMenu: (in category 'menu') ----- - fieldListMenu: aMenu - "Arm the supplied menu with items for the field-list of the receiver" - ^ self menu: aMenu for: #(fieldListMenu fieldListMenuShifted:) - ! Item was removed: - ----- Method: Inspector>>fieldListMenu:shifted: (in category 'menu') ----- - fieldListMenu: aMenu shifted: shifted - "Arm the supplied menu with items for the field-list of the receiver" - ^ self - menu: aMenu - for: #(fieldListMenu fieldListMenuShifted:) - shifted: shifted! Item was removed: - ----- Method: Inspector>>fieldListStyler (in category 'user interface - styling') ----- - fieldListStyler - "This is an extra styler to style the items in the field list. Note that both code and value pane use their own styler." - - ^ fieldListStyler! Item was removed: - ----- Method: Inspector>>fieldSelf (in category 'fields') ----- - fieldSelf - - ^ (self newFieldForType: #self key: #self) - name: 'self'; styleName: ((UserInterfaceTheme current get: #self for: #SHTextStylerST80) ifNil: [#()]); - valueGetter: [:obj | obj]; - valueSetter: [:obj :value | self object: value]; "Switch to another object-under-inspection." - yourself! Item was removed: - ----- Method: Inspector>>fields (in category 'accessing') ----- - fields - - ^ fields ifNil: [#()]! Item was removed: - ----- Method: Inspector>>getContents (in category 'user interface') ----- - getContents - - | newContents | - selectionUpdateTime := 0. - - self hasSelection ifFalse: [^ '']. - - selectionUpdateTime := [ - newContents := self selection in: [:object | - self selectedField shouldPrintValueAsIs - ifTrue: [object asStringOrText] "Show strings and texts without quoting and without ellipsis." - ifFalse: [ - object isInteger - ifTrue: [object storeStringBase: self defaultIntegerBase] - ifFalse: [object printString]]]. - ] timeToRun. - - ^ newContents! Item was removed: - ----- Method: Inspector>>hasCustomFields (in category 'fields - custom') ----- - hasCustomFields - - ^ self customFields notEmpty! Item was removed: - ----- Method: Inspector>>hasSelection (in category 'selection') ----- - hasSelection - "Use #selectedField instead of #selectionIndex to guard against invalid #selectionIndex. Can happen, for example, when adding elements to sets." - - ^ self selectedField notNil! Item was removed: - ----- Method: Inspector>>initialExtent (in category 'initialization') ----- - initialExtent - "Answer the desired extent for the receiver when it is first opened on the screen. " - - ^ 350 @ 250! Item was removed: - ----- Method: Inspector>>initialize (in category 'initialization') ----- - initialize - - super initialize. - - customFields := OrderedCollection new. - selectionIndex := 0. - - fieldListStyler := (TextStyler for: #Smalltalk) - ifNotNil: [:class | class new].! Item was removed: - ----- Method: Inspector>>inspect: (in category 'initialization') ----- - inspect: anObject - "Reinitialize the receiver so that it is inspecting anObject. Become an instance of the appropriate inspectorClass. - - Normally the receiver will be of the correct class (as defined by anObject inspectorClass), because it will have just been created by sending inspect to anObject. However, the debugger uses two embedded inspectors, which are re-targetted on the current receiver each time the stack frame changes. The left-hand inspector in the debugger has its class changed by the code here." - - | inspectorClass | - inspectorClass := anObject inspectorClass. - self class ~= inspectorClass ifTrue: [ - self class format = inspectorClass format - ifTrue: [self primitiveChangeClassTo: inspectorClass basicNew] - ifFalse: [self becomeForward: (self as: inspectorClass)]]. - - self object: anObject.! Item was removed: - ----- Method: Inspector>>inspectOne (in category 'menu - commands') ----- - inspectOne - "This is the most generic case to inspect a specific element from the inspected object. Since trunction of fields is a generic feature, support lookup for those truncated objects also for non-collections." - - self inspectOneOf: (1 to: self object basicSize).! Item was removed: - ----- Method: Inspector>>inspectOneOf: (in category 'menu - commands') ----- - inspectOneOf: someKeys - - | elements labels choice | - someKeys size = 0 ifTrue: [^ self inform: 'Nothing to inspect.' translated]. - someKeys size = 1 ifTrue: [^ (self elementAt: someKeys first) inspect]. - someKeys size > 50 ifTrue: [^ self inspectOneOfFrom: someKeys first to: someKeys last]. - - elements := someKeys collect: [:key | [self elementAt: key] ifError: ['<???>']]. - labels := someKeys with: elements collect: [:key :element | - '{1} -> {2}' format: { - key printString. - [element printString withoutLineEndings withBlanksCondensed truncateWithElipsisTo: 75] - ifError: ['<???>']}]. - choice := Project uiManager chooseFrom: labels title: 'Inspect which field?' translated. - choice = 0 ifTrue: [^ self]. - - (elements at: choice) inspect.! Item was removed: - ----- Method: Inspector>>inspectOneOfFrom:to: (in category 'menu - commands') ----- - inspectOneOfFrom: firstKey to: lastKey - "Let the user specify the desired field's key in the form of a Smalltalk literal or otherwise simple code expression." - - | choiceString | - choiceString := Project uiManager - request: ('Enter the name of the field to inspect.\Names range from {1} to {2}.' translated withCRs - format: {firstKey storeString. lastKey storeString}) - initialAnswer: firstKey storeString. - choiceString isEmptyOrNil ifTrue: [^ self]. - - (self elementAt: (Compiler evaluate: choiceString)) inspect.! Item was removed: - ----- Method: Inspector>>inspectSelection (in category 'menu - commands') ----- - inspectSelection - "Create and schedule an Inspector on the receiver's model's currently selected object." - - self hasSelection ifFalse: [^ self changed: #flash]. - ^ self selectionOrObject inspect! Item was removed: - ----- Method: Inspector>>inspectSelectionBasic (in category 'menu - commands') ----- - inspectSelectionBasic - "Bring up an inspector that focuses on the very basics of an object." - - ^ ToolSet basicInspect: self selectionOrObject! Item was removed: - ----- Method: Inspector>>inspectorKey:from: (in category 'menu') ----- - inspectorKey: aChar from: view - "Respond to a Command key issued while the cursor is over my field list" - - ^ aChar - caseOf: { - [$x] -> [self removeSelection]. - - [$i] -> [self inspectSelection]. - [$I] -> [self exploreSelection]. - [$b] -> [self browseClass]. - [$h] -> [self browseClassHierarchy]. - [$p] -> [self browseFullProtocol]. - [$r] -> [self browseVariableReferences]. - [$a] -> [self browseVariableAssignments]. - [$N] -> [self browseClassRefs]. - [$c] -> [self copyName]. - [$t] -> [self tearOffTile]. - [$v] -> [self viewerForValue] } - otherwise: [self arrowKey: aChar from: view]! Item was removed: - ----- Method: Inspector>>labelString (in category 'user interface - window') ----- - labelString - "See #windowTitle. All tools chose to implement #labelString." - - ^ '{1}{2}' format: { - self object defaultLabelForInspector. - self object isReadOnlyObject - ifTrue: [' (read-only)' translated] - ifFalse: ['']}! Item was removed: - ----- Method: Inspector>>mainFieldListMenu: (in category 'menu') ----- - mainFieldListMenu: aMenu - "Arm the supplied menu with items for the field-list of the receiver" - <fieldListMenu> - aMenu addStayUpItemSpecial. - - self addObjectItemsTo: aMenu. - - (#(self ellipsis element nil) includes: self typeOfSelection) - ifTrue: [self addCollectionItemsTo: aMenu]. - - self typeOfSelection = #instVar - ifTrue: [self addInstVarItemsTo: aMenu]. - - self addFieldItemsTo: aMenu. - self addClassItemsTo: aMenu. - - Smalltalk isMorphic ifTrue: [ - self flag: #refactor. "mt: Extract Etoys-specific extension." - "ct: We could use the <fieldListMenu> pragma if it had a priority argument!!" - self addEtoysItemsTo: aMenu]. - - ^ aMenu! Item was removed: - ----- Method: Inspector>>metaFieldListMenu: (in category 'menu') ----- - metaFieldListMenu: aMenu - <fieldListMenu"Shifted: true"> - self flag: #ct "we need keyboard support for shifted menus. Maybe add an item 'More...'?". - - aMenu addLine. - aMenu addTranslatedList: #( - ('add field...' #addCustomField)). - self selectedField ifNotNil: [:field | - field isCustom ifTrue: [ - field addCustomItemsFor: self to: aMenu]]. - ^ aMenu! Item was removed: - ----- Method: Inspector>>modelWakeUpIn: (in category 'updating - steps') ----- - modelWakeUpIn: aWindow - - self updateFields.! Item was removed: - ----- Method: Inspector>>newCustomField (in category 'fields - custom') ----- - newCustomField - - ^ (self newFieldForType: #custom) - valueGetterExpression: 'self yourself'; - yourself! Item was removed: - ----- Method: Inspector>>newFieldForType: (in category 'fields') ----- - newFieldForType: aSymbol - - ^ self fieldClass type: aSymbol! Item was removed: - ----- Method: Inspector>>newFieldForType:key: (in category 'fields') ----- - newFieldForType: aSymbol key: anObject - - ^ self fieldClass type: aSymbol key: anObject! Item was removed: - ----- Method: Inspector>>noteSelectionIndex:for: (in category 'selection') ----- - noteSelectionIndex: anInteger for: aSymbol - - self flag: #mvcOnly. - aSymbol == #fieldList ifTrue: - [selectionIndex := anInteger].! Item was removed: - ----- Method: Inspector>>object (in category 'accessing') ----- - object - "Answer the object being inspected by the receiver." - - ^object! Item was removed: - ----- Method: Inspector>>object: (in category 'accessing') ----- - object: anObject - "Set anObject to be the object being inspected by the receiver. The current contents, including edits, in the value pane become void because the new object is likely to have new fields with different contents." - - self object == anObject ifTrue: [^ self]. - self resetContents. - - object := anObject. - self changed: #object. - - self changed: #windowTitle. - - self updateFields.! Item was removed: - ----- Method: Inspector>>objectOkToClose (in category 'user interface - window') ----- - objectOkToClose - - ^ (self object respondsTo: #inspectorOkToClose) - ==> [(self object perform: #inspectorOkToClose) == true]! Item was removed: - ----- Method: Inspector>>objectReferencesToSelection (in category 'menu - commands') ----- - objectReferencesToSelection - "Open a list inspector on all the objects that point to the value of the selected object." - - ^ self systemNavigation - browseAllObjectReferencesTo: self selectionOrObject - except: (Array with: self with: self object) - ifNone: [:obj | self changed: #flash]! Item was removed: - ----- Method: Inspector>>okToClose (in category 'user interface - window') ----- - okToClose - "Check custom fields and give the object-under-inspection a chance to react. Maybe this explorer is an important reference to the object and the user needs to be informed about this fact." - - ^ super okToClose - and: [self okToDiscardCustomFields - and: [self objectOkToClose]]! Item was removed: - ----- Method: Inspector>>okToDiscardCustomFields (in category 'user interface - window') ----- - okToDiscardCustomFields - - ^ self hasCustomFields ==> [self confirm: (String streamContents: [:s | - s nextPutAll: 'All custom fields will be discarded:' translated. - self customFields do: [:field | - s crtab; nextPutAll: field name] ])]! Item was removed: - ----- Method: Inspector>>okToRevertChanges: (in category 'user edits') ----- - okToRevertChanges: aspect - "Clear caches since we use #textEdited: callback from view." - - aspect = #expression: ifTrue: [ - expression := '']. - aspect = #typeValue: ifTrue: [ - contentsTyped := nil. - shouldStyleValuePane := false]. - ^ true! Item was removed: - ----- Method: Inspector>>removeCustomField: (in category 'fields - custom') ----- - removeCustomField: aField - - aField isCustom - ifFalse: [^ self changed: #flash]. - (self customFields includes: aField) - ifFalse: [^ self changed: #flash]. - - (self confirm: ('Do you really want to remove the field ''{1}''?' translated format: {aField name})) - ifFalse: [^ self]. - - self customFields remove: aField. - self updateFields.! Item was removed: - ----- Method: Inspector>>removeSelection (in category 'menu - commands') ----- - removeSelection - "In general, we can always remove custom fields. Specialized inspectors can offer to remove other fields such as those representing collection elements." - - self selectedField ifNotNil: [:field | - field isCustom ifTrue: [self removeCustomField: field]].! Item was removed: - ----- Method: Inspector>>replaceInspectorWithExplorer (in category 'toolbuilder') ----- - replaceInspectorWithExplorer - "Switch to an explorer tool. If there are custom fields, the user can choose to not discard them, which will just spawn a new explorer tool besides this inspector." - - | window currentBounds | - self flag: #todo. "ct: In the long term, we should try to communicate specific selectors (here: #expression) along the observer pattern for requests such as #acceptChanges or #wantToChange instead of exploiting contentsTyped etc." - - (self okToDiscardCustomFields and: [contentsTyped notNil ==> [self confirm: - 'Changes have not been saved. - Is it OK to cancel those changes?' translated orCancel: [^ self]]]) - ifFalse: [^ self object explore]. - - self customFields removeAll. - self changed: #contents. "Reset value pane contents before accepting all contents" - self changed: #acceptChanges. "We copy the current state anyway. See below." - currentBounds := ToolBuilder default class getBoundsForWindow: self containingWindow. - - "Close first because MVC fiddles around with processes." - self changed: #close. - - window := ToolSet explore: self object. - - "---- In MVC, the lines after this will not be executed ---" - - window model setExpression: self expression. - ToolBuilder default class setBoundsForWindow: window to: currentBounds.! Item was removed: - ----- Method: Inspector>>replaceSelectionValue: (in category 'selection') ----- - replaceSelectionValue: anObject - "Set the value of the selected field to anObject. We have to answer whether this replacement worked or not." - - | target | - (target := self ensureSelectedField) ifNil: [^ false]. - - target type = #self ifTrue: [ - ^ (self confirm: 'This will exchange the inspected object.' translated) - ifTrue: [self inspect: anObject. true] - ifFalse: [false]]. - - target isReadOnly ifTrue: [ - self inform: 'You cannot replace the selected field because\it is read-only. Try to add a field setter.' withCRs. - ^ false]. - - self contentsTyped: nil. "Ensure to refresh the contents view." - - target - setValueFor: self - to: anObject. - - ^ true! Item was removed: - ----- Method: Inspector>>representsSameBrowseeAs: (in category 'user interface') ----- - representsSameBrowseeAs: anotherInspector - - ^ self object == anotherInspector object! Item was removed: - ----- Method: Inspector>>requestCustomFieldOrCancel: (in category 'fields - custom') ----- - requestCustomFieldOrCancel: aBlock - - ^ self newCustomField - requestCustomFor: self - orCancel: aBlock! Item was removed: - ----- Method: Inspector>>resetContents (in category 'initialization') ----- - resetContents - - self setContents: nil.! Item was removed: - ----- Method: Inspector>>resetFields (in category 'initialization') ----- - resetFields - - "1) Discard existing fields." - fields ifNotNil: [ - fields do: [:field | field removeDependent: self]. - fields := nil "Just in case there is an error in the following calls."]. - - "2a) Create new fields." - fields := Array streamContents: [:stream | - | workBlock | - workBlock := [self streamFieldsOn: stream]. - workBlock ifError: [self streamErrorDoing: workBlock on: stream]]. - - "2b) Establish field dependency." - fields do: [:field | field addDependent: self]. - - "3) Tell the views." - self updateFieldList.! Item was removed: - ----- Method: Inspector>>selectField: (in category 'selection') ----- - selectField: aField - - self selectionIndex: (self fields indexOf: aField ifAbsent: [0])! Item was removed: - ----- Method: Inspector>>selectFieldNamed: (in category 'selection') ----- - selectFieldNamed: aString - "Select the field that is labeled aFieldName, or nothing, is there is no match." - - self selectFieldSuchThat: [:field | field name = aString].! Item was removed: - ----- Method: Inspector>>selectFieldSuchThat: (in category 'selection') ----- - selectFieldSuchThat: aBlock - "Select the first field for which aBlock evaluates to true." - - self selectionIndex: (self fields findFirst: aBlock).! Item was removed: - ----- Method: Inspector>>selectedClass (in category 'selection - convenience') ----- - selectedClass - - ^ self object class! Item was removed: - ----- Method: Inspector>>selectedField (in category 'selection') ----- - selectedField - - ^ self fields - at: self selectionIndex - ifAbsent: [nil]! Item was removed: - ----- Method: Inspector>>selectedFieldName (in category 'selection') ----- - selectedFieldName - - ^ self selectedField ifNotNil: [:field | field name]! Item was removed: - ----- Method: Inspector>>selectedInstVarName (in category 'selection - convenience') ----- - selectedInstVarName - - ^ self selectedField ifNotNil: [:field | - field type = #instVar - ifTrue: [field key] - ifFalse: [nil]].! Item was removed: - ----- Method: Inspector>>selection (in category 'selection') ----- - selection - "Answer the value of the selected variable slot, that is an object." - - ^ self selectedField getValueFor: self! Item was removed: - ----- Method: Inspector>>selectionIndex (in category 'accessing') ----- - selectionIndex - - ^ selectionIndex! Item was removed: - ----- Method: Inspector>>selectionIndex: (in category 'accessing') ----- - selectionIndex: anInteger - "Changes the index to determine the currently selected field. If the field is already selected, update the fields contents in the value pane." - - self selectionIndex = anInteger - ifTrue: [^ self updateContentsSafely]. - - selectionIndex := anInteger. - self changed: #selectionIndex. - - self updateContentsSafely.! Item was removed: - ----- Method: Inspector>>selectionIsReadOnly (in category 'selection - convenience') ----- - selectionIsReadOnly - "Answer if the current selected variable is not modifiable via acceptance in the code pane. For example, a selection of 'all inst vars' is unmodifiable." - - ^ self selectedField - ifNil: [true] - ifNotNil: [:field | field isReadOnly]! Item was removed: - ----- Method: Inspector>>selectionOrObject (in category 'selection - convenience') ----- - selectionOrObject - "My selection. If nothing useful is selected, return the inspected object instead." - - self hasSelection ifFalse: [^ self object]. - self typeOfSelection = #ellipsis ifTrue: [^ self object]. - - ^ self selection! Item was removed: - ----- Method: Inspector>>setContents: (in category 'initialization') ----- - setContents: aStringOrText - "Do not style the value pane anymore. Clear the #contentsTyped buffer." - - shouldStyleValuePane := false. - super setContents: aStringOrText. - self contentsTyped: nil.! Item was removed: - ----- Method: Inspector>>setContentsTyped: (in category 'initialization') ----- - setContentsTyped: aStringOrText - "Simulate typing." - - shouldStyleValuePane := true. - self contentsTyped: aStringOrText. - - self flag: #refactor. "mt: #changed: is not able to specify the receiver ..." - self valuePane ifNotNil: [:pane | - pane update: #editString with: aStringOrText].! Item was removed: - ----- Method: Inspector>>setExpression: (in category 'initialization') ----- - setExpression: aString - "Set the code string in the code pane after switching between Inspector/Explorer. See #replaceInspectorWithExplorer." - - self expression: aString. - self changed: #expression.! Item was removed: - ----- Method: Inspector>>stepAt:in: (in category 'updating - steps') ----- - stepAt: millisecondClockValue in: aWindow - - self updateFields.! Item was removed: - ----- Method: Inspector>>stepTimeIn: (in category 'updating - steps') ----- - stepTimeIn: aWindow - "Minimum step time is 1 second. If the fetching of contents takes more than 100 milliseconds, increase the step time accordingly to keep the system responsive." - - ^ (selectionUpdateTime ifNil: [0]) * 10 max: 1000! Item was removed: - ----- Method: Inspector>>streamBaseFieldsOn: (in category 'fields - streaming') ----- - streamBaseFieldsOn: aStream - - aStream - nextPut: self fieldSelf; - nextPut: self fieldAllInstVars.! Item was removed: - ----- Method: Inspector>>streamCustomFieldsOn: (in category 'fields - streaming') ----- - streamCustomFieldsOn: aStream - - aStream nextPutAll: self customFields.! Item was removed: - ----- Method: Inspector>>streamError:on: (in category 'fields - error handling') ----- - streamError: aMessageString on: aStream - - aStream nextPut: ((self newFieldForType: #error) - name: (Text - string: '<error>' translated - attribute: self textColorForError); - valueGetter: [:object | self emphasizeError: aMessageString]; - printValueAsIs; - yourself)! Item was removed: - ----- Method: Inspector>>streamErrorDoing:on: (in category 'fields - error handling') ----- - streamErrorDoing: aBlock on: aStream - - self - streamError: (self contentsForErrorDoing: aBlock) - on: aStream.! Item was removed: - ----- Method: Inspector>>streamFieldsOn: (in category 'fields - streaming') ----- - streamFieldsOn: aStream - - self - streamBaseFieldsOn: aStream; - streamVariableFieldsOn: aStream; - streamCustomFieldsOn: aStream.! Item was removed: - ----- Method: Inspector>>streamIndexedVariablesOn: (in category 'fields - streaming') ----- - streamIndexedVariablesOn: aStream - "Truncate indexed variables if there are too many of them." - - self - streamOn: aStream - truncate: (1 to: self object basicSize) - collectFields: [:index | - (self newFieldForType: #indexed key: index) - valueGetter: [:object | object basicAt: index]; - valueSetter: [:object :value | object basicAt: index put: value]; - yourself]! Item was removed: - ----- Method: Inspector>>streamInstanceVariablesOn: (in category 'fields - streaming') ----- - streamInstanceVariablesOn: aStream - - | attributesForInstVars | - attributesForInstVars := (UserInterfaceTheme current get: #instVar for: #SHTextStylerST80) ifNil: [#()]. - - (self object perform: #class "do not inline send of #class, receiver could be a proxy") allInstVarNames withIndexDo: [:name :index | - aStream nextPut: ((self newFieldForType: #instVar key: name) - name: name; styleName: attributesForInstVars; - valueGetter: [:obj | obj instVarNamed: name]; - valueSetter: [:obj :value | obj instVarNamed: name put: value]; - yourself)].! Item was removed: - ----- Method: Inspector>>streamOn:truncate:collectFields: (in category 'fields - truncation') ----- - streamOn: aStream truncate: aList collectFields: aBlock - - ^ self - streamOn: aStream - truncate: aList - collectFields: aBlock - ellipsisFrom: [:truncatedObjects | (self newFieldForType: #ellipsis) - name: '...'; - valueGetter: [:object | self contentsForTruncationOf: truncatedObjects]; - printValueAsIs; - yourself]! Item was removed: - ----- Method: Inspector>>streamOn:truncate:collectFields:ellipsisFrom: (in category 'fields - truncation') ----- - streamOn: aStream truncate: someObjects collectFields: fieldBlock ellipsisFrom: ellipsisBlock - "Create fields for someObjects using fieldBlock. Using the current #truncationLimit, create an extra ellipsis field to hide objects that go beyond this limit." - - (someObjects size <= self truncationLimit or: [self truncationLimit < 0]) - ifTrue: [^ aStream nextPutAll: (someObjects withIndexCollect: [:each :index | fieldBlock cull: each cull: index])]. - - someObjects readStream in: [:readStream | | offset | - offset := readStream size - self truncationTail. - aStream - nextPutAll: ((readStream next: self truncationLimit - self truncationTail - 1) - withIndexCollect: [:each :index | fieldBlock cull: each cull: index]); - nextPut: (ellipsisBlock value: (readStream upToPosition: offset)); - nextPutAll: (readStream upToEnd - withIndexCollect: [:each :index | fieldBlock cull: each cull: index + offset])].! Item was removed: - ----- Method: Inspector>>streamVariableFieldsOn: (in category 'fields - streaming') ----- - streamVariableFieldsOn: aStream - - self - streamInstanceVariablesOn: aStream; - streamIndexedVariablesOn: aStream.! Item was removed: - ----- Method: Inspector>>textColorForError (in category 'user interface') ----- - textColorForError - - ^ TextColor color: ((UserInterfaceTheme current get: #errorColor for: #TestRunner) ifNil: [Color red])! Item was removed: - ----- Method: Inspector>>truncationLimit (in category 'fields - truncation') ----- - truncationLimit - "The maximum number of fields to show when truncating a list of objects. For example, collections can have a very big number of indexed variables and the inspecter would become slow without this limit. Keep the system responsive. Note that there is an extra ellipsis field for the truncated items so that users can manually select the (truncated) indexed variable to inspect. - - Choose a limit < 0 to not truncate any fields." - - ^ 100! Item was removed: - ----- Method: Inspector>>truncationTail (in category 'fields - truncation') ----- - truncationTail - "The number of fields to show at the end of a truncated field run." - - ^ 10! Item was removed: - ----- Method: Inspector>>typeOfSelection (in category 'selection - convenience') ----- - typeOfSelection - - ^ self selectedField ifNotNil: [:field | field type]! Item was removed: - ----- Method: Inspector>>typeValue: (in category 'user interface - styling') ----- - typeValue: aTextOrString - "Style field value contents only after the user typed." - - contentsTyped := aTextOrString. - - shouldStyleValuePane == true ifFalse: [ - shouldStyleValuePane := true. - self changed: #style].! Item was removed: - ----- Method: Inspector>>update (in category 'updating') ----- - update - "For convenience." - - self updateFields.! Item was removed: - ----- Method: Inspector>>update: (in category 'updating') ----- - update: what - - what = #field ifTrue: [ - self updateFieldList. - self updateContentsSafely]. - - ^ super update: what! Item was removed: - ----- Method: Inspector>>update:with: (in category 'updating') ----- - update: what with: parameter - - what = #deleteField - ifTrue: [self removeCustomField: parameter]. - - ^ super update: what with: parameter! Item was removed: - ----- Method: Inspector>>updateContentsSafely (in category 'updating') ----- - updateContentsSafely - "Force update contents of selected field. Do not style the contents anymore. Discard unaccepted changes in text fields." - - | workBlock | - workBlock := [self getContents]. - self setContents: (workBlock - ifError: [self emphasizeError: (self contentsForErrorDoing: workBlock)]).! Item was removed: - ----- Method: Inspector>>updateFieldList (in category 'updating') ----- - updateFieldList - - self changed: #fieldList. - self changed: #selectionIndex. "In case a field got renamed, tell the view that the selection did not change at all. The view would otherwise assume it is gone after updating the list and clear the selection. That's a little interference with the built-in list filtering mechanism in the view."! Item was removed: - ----- Method: Inspector>>updateFields (in category 'updating') ----- - updateFields - "Reset the collection of fields. Since amount and content my change, try to keep the current selection by field identity or field name." - - | field edits | - field := self hasSelection ifTrue: [self selectedField]. "Save user selection" - edits := self contentsTyped. "Save user edits" - - self resetFields. - - "Restore user selection" - field ifNotNil: [ - (self fields identityIncludes: field) - ifTrue: [self selectField: field] - ifFalse: [self selectFieldNamed: field name]]. - - "Restore user edits only if selection was restored." - (edits notNil and: [self selectedField = field or: [self selectedFieldName = field name]]) - ifTrue: [self setContentsTyped: edits]. - ! Item was removed: - ----- Method: Inspector>>updateListsAndCodeIn: (in category 'updating - steps') ----- - updateListsAndCodeIn: aWindow - "Not needed. We have everything in place to update from here. See #updateFields. No need to update through views."! Item was removed: - ----- Method: Inspector>>updateStyler: (in category 'user interface - styling') ----- - updateStyler: aStyler - - self updateStyler: aStyler requestor: self.! Item was removed: - ----- Method: Inspector>>updateStyler:requestor: (in category 'user interface - styling') ----- - updateStyler: aStyler requestor: anObject - "Use this method to update our fieldListStyler and all view stylers." - - aStyler - environment: self environment; - classOrMetaClass: (self doItReceiver perform: #class "do not inline send of #class, receiver could be a proxy"); - context: self doItContext; - parseAMethod: false; - workspace: nil "Normally we don't need this, but probably a workspace has been specified when the receiver was belonging to another class. See #inspect: and BlockClosureInspector >> #updateStyler:requestor:.".! Item was removed: - ----- Method: Inspector>>valuePane (in category 'user interface') ----- - valuePane - "Private. This is a workaround to interact with the value pane directly and not interfere with the code pane." - - ^ self dependents - detect: [:object | object knownName = #valuePane] - ifNone: []! Item was removed: - ----- Method: Inspector>>veryDeepInner: (in category 'copying') ----- - veryDeepInner: aDeepCopier - super veryDeepInner: aDeepCopier. - expression := expression veryDeepCopyWith: aDeepCopier. - contentsTyped := contentsTyped veryDeepCopyWith: aDeepCopier! Item was removed: - ----- Method: Inspector>>wantsStepsIn: (in category 'updating - steps') ----- - wantsStepsIn: aWindow - "Independent of #smartUpdating preference". - - ^ true! Item was removed: - Model subclass: #InspectorBrowser - instanceVariableNames: 'inspector browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !InspectorBrowser commentStamp: 'tcj 3/12/2018 07:55' prior: 0! - I am an inspector that also shows all messages the inspected objects can understand. I combine inspector and code browser. - - InspectorBrowser openOn: Smalltalk! Item was removed: - ----- Method: InspectorBrowser class>>basicInspect: (in category 'inspector compatibility') ----- - basicInspect: anObject - "ToolBuilder open: (self basicInspect: Morph new)" - - ^ self new - setInspectorClass: BasicInspector; - object: anObject; - yourself! Item was removed: - ----- Method: InspectorBrowser class>>inspect: (in category 'inspector compatibility') ----- - inspect: anObject - "ToolBuilder open: (self inspect: 42)" - - ^ self new inspect: anObject! Item was removed: - ----- Method: InspectorBrowser class>>on: (in category 'instance creation') ----- - on: anObject - "We have to call #inspect: instead of #object: to choose the correct #inspectorClass." - - ^ self new inspect: anObject! Item was removed: - ----- Method: InspectorBrowser class>>openOn: (in category 'instance creation') ----- - openOn: anObject - - ^ ToolBuilder open: (self on: anObject)! Item was removed: - ----- Method: InspectorBrowser class>>openOn:withLabel: (in category 'instance creation') ----- - openOn: anObject withLabel: label - - ^ ToolBuilder open: (self on: anObject) label: label! Item was removed: - ----- Method: InspectorBrowser>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - - | windowSpec | - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 0.3 at 0.3) -> [inspector buildFieldListWith: builder]. - (0.3 at 0 corner: 1.0 at 0.3) -> [inspector buildValuePaneWith: builder]. - (0 at 0.3 corner: 0.3 at 1.0) -> [browser buildMessageListWith: builder]. - (0.3 at 0.3 corner: 1.0 at 1.0) -> [browser buildCodePaneWith: builder]. - }. - ^ builder build: windowSpec! Item was removed: - ----- Method: InspectorBrowser>>initialExtent (in category 'initialization') ----- - initialExtent - - ^ (inspector initialExtent x max: browser initialExtent x) - @ ((inspector initialExtent y * 2/3) + browser initialExtent y)! Item was removed: - ----- Method: InspectorBrowser>>initialize (in category 'initialization') ----- - initialize - - super initialize. - - self setInspectorClass: Inspector. - self setBrowserClass: Browser.! Item was removed: - ----- Method: InspectorBrowser>>inspect: (in category 'initialization') ----- - inspect: anObject - "Reinitialize the inspector so that it is inspecting anObject." - - inspector inspect: anObject. - browser setClass: anObject class.! Item was removed: - ----- Method: InspectorBrowser>>labelString (in category 'toolbuilder') ----- - labelString - "The window title" - - ^ 'Inspector Browser: ', inspector labelString! Item was removed: - ----- Method: InspectorBrowser>>modelWakeUpIn: (in category 'stepping') ----- - modelWakeUpIn: aWindow - - inspector modelWakeUpIn: aWindow. - browser modelWakeUpIn: aWindow.! Item was removed: - ----- Method: InspectorBrowser>>object (in category 'accessing') ----- - object - - ^ inspector object! Item was removed: - ----- Method: InspectorBrowser>>object: (in category 'accessing') ----- - object: anObject - "Set anObject to be the object being inspected by the receiver." - - inspector object: anObject. - browser setClass: anObject class.! Item was removed: - ----- Method: InspectorBrowser>>setBrowserClass: (in category 'initialization') ----- - setBrowserClass: aClass - - browser := aClass new.! Item was removed: - ----- Method: InspectorBrowser>>setInspectorClass: (in category 'initialization') ----- - setInspectorClass: aClass - - inspector := aClass new. - inspector addDependent: self.! Item was removed: - ----- Method: InspectorBrowser>>stepAt:in: (in category 'stepping') ----- - stepAt: millisecondClockValue in: aWindow - - inspector stepAt: millisecondClockValue in: aWindow. - browser stepAt: millisecondClockValue in: aWindow.! Item was removed: - ----- Method: InspectorBrowser>>stepTimeIn: (in category 'stepping') ----- - stepTimeIn: aWindow - - ^ (inspector stepTimeIn: aWindow) - max: (browser stepTimeIn: aWindow)! Item was removed: - ----- Method: InspectorBrowser>>update: (in category 'updating') ----- - update: anAspect - "When the inspector exchanges the object-under-inspection, reset the class of my browser." - - anAspect = #object ifTrue: [ - browser setClass: inspector object class]. - anAspect = #windowTitle ifTrue: [ - self changed: #windowTitle]. - super update: anAspect.! Item was removed: - ----- Method: InspectorBrowser>>updateListsAndCodeIn: (in category 'stepping') ----- - updateListsAndCodeIn: aWindow - - inspector updateListsAndCodeIn: aWindow. - browser updateListsAndCodeIn: aWindow.! Item was removed: - ----- Method: InspectorBrowser>>wantsStepsIn: (in category 'stepping') ----- - wantsStepsIn: aWindow - - ^ (inspector wantsStepsIn: aWindow) - or: [browser wantsStepsIn: aWindow]! Item was removed: - Object subclass: #InspectorField - instanceVariableNames: 'key valueGetter valueGetterExpression valueSetter valueSetterExpression name shouldStyleName shouldStyleValue shouldPrintValueAsIs type inspector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !InspectorField commentStamp: 'mt 3/9/2020 14:34' prior: 0! - I represent a single field of an Inspector in which I am composed. - - I am basically a pair of #key and #value, but may have an extra human-readable #name to be shown in the Inspector's views. My #value can only be accessed in scope of an Inspector because I need an #object to work with.! Item was removed: - ----- Method: InspectorField class>>generateExpressionFrom:argumentNames: (in category 'support') ----- - generateExpressionFrom: aBlock argumentNames: argumentNames - - | blockNode arguments variables context receiver | - self flag: #experimental. - blockNode := aBlock decompile veryDeepCopy. "some literals are singletons, see #becomeForward: below" - arguments := blockNode arguments collect: #name. - variables := Dictionary new. - variables - at: #true put: true; - at: #false put: false; - at: #nil put: nil. - receiver := aBlock receiver. - receiver class allInstVarNames - withIndexDo: [:name :index | - variables at: name put: (receiver instVarAt: index)]. - context := aBlock outerContext. - context tempNames - withIndexDo: [:name :index | - variables at: name put: (context namedTempAt: index)]. - blockNode nodesDo: [:node | - self flag: #ct. "Should we introduce #nodesCollect: instead of using dangerous #becomeForward:?" - { - [node isVariableNode not]. - [| argumentIndex | - argumentIndex := arguments indexOf: node name. - argumentIndex isZero - ifFalse: [node name: (argumentNames at: argumentIndex)]; - not]. - [variables at: node name - ifPresent: [:value | - value isLiteral - ifTrue: [node becomeForward: (LiteralNode new key: value)]; - yourself] - ifAbsent: [^ nil]]. - } detect: #value ifNone: [^ nil]]. - ^ String streamContents: [:stream | - blockNode - printStatementsOn: stream - indent: 0].! Item was removed: - ----- Method: InspectorField class>>type: (in category 'instance creation') ----- - type: aSymbol - - ^ self new - type: aSymbol; - yourself! Item was removed: - ----- Method: InspectorField class>>type:key: (in category 'instance creation') ----- - type: aSymbol key: anObject - - ^ (self type: aSymbol) - key: anObject - yourself! Item was removed: - ----- Method: InspectorField>>addCustomItemsFor:to: (in category 'menu - construction') ----- - addCustomItemsFor: anInspector to: aMenu - - aMenu - addLine; - add: 'edit field name...' translated target: self selector: #editName; - add: 'edit field getter...' translated target: self selector: #editGetterFor: argument: anInspector; - add: (self valueSetter ifNil: ['add field setter...' translated] ifNotNil: ['edit field setter...' translated]) - target: self selector: #editSetterFor: argument: anInspector; - addLine; - add: ('remove field ''{1}'' (x)' translated format: {self name}) target: self selector: #delete.! Item was removed: - ----- Method: InspectorField>>deEmphasizeName (in category 'initialization') ----- - deEmphasizeName - - self flag: #hardcoded. - self styleName: - {TextColor color: - ((UserInterfaceTheme current get: #balloonTextColor for: #PluggableTextMorphPlus) - ifNil: [Color gray])}.! Item was removed: - ----- Method: InspectorField>>delete (in category 'custom - actions') ----- - delete - "Request the deletion of this field in my inspector's list of (custom) fields." - - self changed: #deleteField with: self.! Item was removed: - ----- Method: InspectorField>>editGetterFor: (in category 'custom - actions') ----- - editGetterFor: aStringHolder - - ^ self editGetterFor: aStringHolder orCancel: []! Item was removed: - ----- Method: InspectorField>>editGetterFor:orCancel: (in category 'custom - actions') ----- - editGetterFor: anInspector orCancel: aBlock - - | code | - code := Project uiManager - request: 'Please enter an evaluable expression<br>to <b>get</b> this field''s value:' translated asTextFromHtml - initialAnswer: self valueGetterExpression. - code isEmptyOrNil ifTrue: [^ aBlock value]. - - ^ self setGetterFor: anInspector to: code ifFail: aBlock! Item was removed: - ----- Method: InspectorField>>editName (in category 'custom - actions') ----- - editName - - ^ self editNameOrCancel: []! Item was removed: - ----- Method: InspectorField>>editNameOrCancel: (in category 'custom - actions') ----- - editNameOrCancel: aBlock - - | newTitle | - newTitle := Project uiManager - request: 'Please enter a new name for this field:' translated withCRs - initialAnswer: self name asString. - newTitle isEmptyOrNil ifTrue: [^ aBlock value]. - self name: newTitle; emphasizeName. - self changed: #field.! Item was removed: - ----- Method: InspectorField>>editSetterFor: (in category 'custom - actions') ----- - editSetterFor: anInspector - - ^ self editSetterFor: anInspector orCancel: []! Item was removed: - ----- Method: InspectorField>>editSetterFor:orCancel: (in category 'custom - actions') ----- - editSetterFor: anInspector orCancel: aBlock - - | code | - code := Project uiManager - request: 'Please enter an evaluable expression<br>to <b>set</b> this field''s value:' translated asTextFromHtml - initialAnswer: (self valueSetterExpression ifNil: '[:value | self ___: value]'). - code isEmptyOrNil ifTrue: [^ aBlock value]. - ^ self setSetterFor: anInspector to: code ifFail: aBlock! Item was removed: - ----- Method: InspectorField>>emphasizeName (in category 'initialization') ----- - emphasizeName - - self flag: #hardcoded. - self styleName: { - self isCustom - ifFalse: [TextEmphasis italic] - ifTrue: [TextColor color: - ((UserInterfaceTheme current get: #highlightTextColor for: #SimpleHierarchicalListMorph) - ifNil: [Color red])]}! Item was removed: - ----- Method: InspectorField>>expressionWithReceiverName: (in category 'accessing - code') ----- - expressionWithReceiverName: receiverName - "The code string to run for getting the receiver's value. The receiver's name, which is usually #self, can be replaced to fit specific debugging scenarios such as ThisContext." - - ^ valueGetterExpression ifNil: [ - self valueGetter isCompiledCode - ifTrue: [ "precompiled user code" - self valueGetter getSource ] - ifFalse: [ "evaluable" - self class - generateExpressionFrom: self valueGetter - argumentNames: {receiverName} ] ]! Item was removed: - ----- Method: InspectorField>>forgetInspector (in category 'private') ----- - forgetInspector - - inspector := nil.! Item was removed: - ----- Method: InspectorField>>getValueFor: (in category 'evaluating') ----- - getValueFor: anInspector - - ^ self valueGetter isCompiledCode - ifTrue: [ "precompiled user code" - self valueGetter - valueWithReceiver: anInspector doItReceiver - arguments: ({anInspector doItContext} first: self valueGetter numArgs)] - ifFalse: [ "evaluable" - self valueGetter value: anInspector object ]! Item was removed: - ----- Method: InspectorField>>inspector (in category 'private') ----- - inspector - - ^ inspector ifNil: [self dependents - detect: [:object | object isKindOf: Inspector] - ifNone: [nil]]! Item was removed: - ----- Method: InspectorField>>isCustom (in category 'testing') ----- - isCustom - - ^ self type = #custom! Item was removed: - ----- Method: InspectorField>>isReadOnly (in category 'testing') ----- - isReadOnly - - ^ self valueSetter isNil! Item was removed: - ----- Method: InspectorField>>key (in category 'accessing') ----- - key - - ^ key! Item was removed: - ----- Method: InspectorField>>key: (in category 'accessing') ----- - key: anObject - - self key = anObject ifTrue: [^ self]. - key := anObject. - self changed: #field.! Item was removed: - ----- Method: InspectorField>>name (in category 'accessing') ----- - name - "Answers most human-readable name for this field. Not that the key can be any kind of object but this message should answer something that is already printable such as String or Text. If the sender could not rely on this, quoted strings could be confused with regular strings." - - ^ name ifNil: [valueGetterExpression ifNil: [key ifNil: [''] ifNotNil: [key asString]]]! Item was removed: - ----- Method: InspectorField>>name: (in category 'accessing') ----- - name: aString - - name = aString ifTrue: [^ self]. - name := aString. - self changed: #field.! Item was removed: - ----- Method: InspectorField>>printOn: (in category 'printing') ----- - printOn: aStream - - super printOn: aStream. - aStream - nextPut: $<; - print: self type; - nextPut: $>. - aStream - nextPutAll: ' named '; - print: self name asString.! Item was removed: - ----- Method: InspectorField>>printValueAsIs (in category 'initialization') ----- - printValueAsIs - - self shouldPrintValueAsIs: true.! Item was removed: - ----- Method: InspectorField>>rememberInspector (in category 'private') ----- - rememberInspector - - inspector := self inspector.! Item was removed: - ----- Method: InspectorField>>requestCustomFor:orCancel: (in category 'custom') ----- - requestCustomFor: anInspector orCancel: aBlock - - self setGetterFor: anInspector to: 'self yourself' ifFail: [^ self]. - self editGetterFor: anInspector orCancel: aBlock. - self emphasizeName.! Item was removed: - ----- Method: InspectorField>>setGetterFor:to:ifFail: (in category 'custom') ----- - setGetterFor: anInspector to: code ifFail: aBlock - - | getter | - getter := Compiler new - compiledMethodFor: code - in: anInspector doItContext - to: anInspector doItReceiver - notifying: nil - ifFail: [^ aBlock value]. - - self valueGetterExpression: code. - self valueGetter: getter. - - self changed: #field.! Item was removed: - ----- Method: InspectorField>>setSetterFor:to:ifFail: (in category 'custom') ----- - setSetterFor: anInspector to: code ifFail: aBlock - - | setter | - setter := Compiler new - evaluate: code - in: anInspector doItContext - to: anInspector doItReceiver - environment: anInspector environment - notifying: nil - ifFail: [^ aBlock value] - logged: false. - - self - flag: #experimental; "ct: We might want to change this when input-request dialogs can work with source code. See also http://forum.world.st/Changeset-requestCode-cs-td5110502.html for this proposal." - assert: [setter respondsTo: #value:] - description: 'Setter must be evaluable like a block with one argument' translated. - - self valueSetterExpression: code. - self valueSetter: [:object :value | setter value: value]. - - self changed: #field.! Item was removed: - ----- Method: InspectorField>>setValueFor:to: (in category 'evaluating') ----- - setValueFor: anInspector to: value - - self valueSetter isCompiledCode - ifTrue: [ "precompiled user code" - self valueSetter - valueWithReceiver: anInspector doItReceiver - arguments: ({value. anInspector doItContext} first: self valueSetter numArgs)] - ifFalse: [ "evaluable" - self valueSetter value: anInspector object value: value ]. - self changed: #field.! Item was removed: - ----- Method: InspectorField>>shouldPrintValueAsIs (in category 'accessing - printing') ----- - shouldPrintValueAsIs - "Whether to call #asString or #printString on this field's value." - - ^ shouldPrintValueAsIs ifNil: [false]! Item was removed: - ----- Method: InspectorField>>shouldPrintValueAsIs: (in category 'accessing - printing') ----- - shouldPrintValueAsIs: aBoolean - "Whether to call #asString or #printString on this field's value." - - shouldPrintValueAsIs := aBoolean.! Item was removed: - ----- Method: InspectorField>>shouldStyleName (in category 'accessing - printing') ----- - shouldStyleName - - ^ shouldStyleName ifNil: [false]! Item was removed: - ----- Method: InspectorField>>shouldStyleName: (in category 'accessing - printing') ----- - shouldStyleName: aBoolean - - self shouldStyleName = aBoolean ifTrue: [^ self]. - shouldStyleName := aBoolean. - self changed: #field.! Item was removed: - ----- Method: InspectorField>>shouldStyleValue (in category 'accessing - printing') ----- - shouldStyleValue - - ^ shouldStyleValue ifNil: [false]! Item was removed: - ----- Method: InspectorField>>shouldStyleValue: (in category 'accessing - printing') ----- - shouldStyleValue: aBoolean - - self shouldStyleValue = aBoolean ifTrue: [^ self]. - shouldStyleValue := aBoolean. - self changed: #field.! Item was removed: - ----- Method: InspectorField>>styleName: (in category 'initialization') ----- - styleName: someTextAttributesOrColors - - self name: (self name asText - addAllAttributes: (someTextAttributesOrColors - collect: [:ea | ea isColor ifTrue: [TextColor color: ea] ifFalse: [ea]]); - yourself).! Item was removed: - ----- Method: InspectorField>>type (in category 'accessing') ----- - type - - ^ type! Item was removed: - ----- Method: InspectorField>>type: (in category 'accessing') ----- - type: aSymbol - - type := aSymbol! Item was removed: - ----- Method: InspectorField>>value (in category 'accessing') ----- - value - "For convenience only. If you have an #inspector, call #getValueFor: directly. It may be faster." - - ^ self getValueFor: self inspector! Item was removed: - ----- Method: InspectorField>>value: (in category 'accessing') ----- - value: anObject - "For convenience only. If you have an #inspector, call #setValueFor:to: directly. It may be faster." - - ^ self setValueFor: self inspector to: anObject! Item was removed: - ----- Method: InspectorField>>valueGetter (in category 'accessing - code') ----- - valueGetter - "The valueGetter will be used to fetch a value for this field. See comment in #valueGetter:." - - ^ valueGetter! Item was removed: - ----- Method: InspectorField>>valueGetter: (in category 'accessing - code') ----- - valueGetter: evaluable - "The valueGetter will be used to fetch a value for this field. The corresponding inspctor will provide an object to fetch the value from. - - Here are some examples: - - [:object | object size] -- The most basic case. - #negated --- A convenient shortcut. - [:object | self print: object] --- A closured helper to fetch the value. - - It is also possible to store a compiled method as a valueGetter. Then, the corresponding inspector will provide both #doItReceiver and #doItContext to execute that method to fetch the value for this field. So, this is like storing a compiled do-it expression." - - valueGetter := evaluable.! Item was removed: - ----- Method: InspectorField>>valueGetterExpression (in category 'accessing - code') ----- - valueGetterExpression - "The code string to run for getting the receiver's value." - - ^ self expressionWithReceiverName: #self! Item was removed: - ----- Method: InspectorField>>valueGetterExpression: (in category 'accessing - code') ----- - valueGetterExpression: aString - - valueGetterExpression := aString.! Item was removed: - ----- Method: InspectorField>>valueSetter (in category 'accessing - code') ----- - valueSetter - "The valueSetter will be used to manipulate the value for this field. See comment in #valueSetter:." - - ^ valueSetter! Item was removed: - ----- Method: InspectorField>>valueSetter: (in category 'accessing - code') ----- - valueSetter: oneArgEvaluable - "The valueSetter will be used to manipulate the value for this field. It follows the same semantics as the valueGetter, but expects one more argument, which is the new value to set. See also comment in #valueGetter:. - - Here are some examples: - - [:object :value | object someProperty: value] -- The most basic case. - #someProperty: --- A convenient shortcut. - [:object :value | self setProperty: value in: object] --- A closured helper to set the value." - - valueSetter := oneArgEvaluable! Item was removed: - ----- Method: InspectorField>>valueSetterExpression (in category 'accessing - code') ----- - valueSetterExpression - - ^ valueSetterExpression! Item was removed: - ----- Method: InspectorField>>valueSetterExpression: (in category 'accessing - code') ----- - valueSetterExpression: aString - - valueSetterExpression := aString.! Item was removed: - ----- Method: InstructionStream>>abstractPC (in category '*Tools-Debugger-support') ----- - abstractPC - ^self method abstractPCForConcretePC: pc! Item was removed: - ----- Method: InstructionStream>>debuggerMap (in category '*Tools-Debugger-support') ----- - debuggerMap - ^self method debuggerMap! Item was removed: - ----- Method: Integer>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Integer'! Item was removed: - ----- Method: Magnitude class>>toolIcon (in category '*Tools-icons') ----- - toolIcon - - ^ #magnitude! Item was removed: - ----- Method: Message>>createStubMethod (in category '*Tools-Debugger') ----- - createStubMethod - | argNames | - argNames := Set new. - ^ String streamContents: [ :s | - self selector keywords withIndexDo: [ :key :i | - | aOrAn argName arg argClassName | - s nextPutAll: key. - ((key last = $:) or: [self selector isInfix]) ifTrue: [ - arg := self arguments at: i. - argClassName := arg canonicalArgumentName. - aOrAn := argClassName first isVowel ifTrue: ['an'] ifFalse: ['a']. - argName := aOrAn, argClassName. - [argNames includes: argName] whileTrue: [argName := argName, i asString]. - argNames add: argName. - s nextPutAll: ' '; nextPutAll: argName; space - ]. - ]. - s cr; tab. - s nextPutAll: 'self shouldBeImplemented' - ].! Item was removed: - MessageSet subclass: #MessageNames - instanceVariableNames: 'searchString selectorList selectorListIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! Item was removed: - ----- Method: MessageNames class>>methodBrowserSearchingFor: (in category 'instance creation') ----- - methodBrowserSearchingFor: searchString - "Answer an method-browser window whose search-string is initially as indicated" - - | aWindow | - aWindow := self new searchString: searchString. - ^ToolBuilder default build: aWindow! Item was removed: - ----- Method: MessageNames class>>openMessageNames (in category 'instance creation') ----- - openMessageNames - "Open a new instance of the receiver in the active world" - ^(ToolBuilder open: self new) model - - "MessageNames openMessageNames" - ! Item was removed: - ----- Method: MessageNames class>>prototypicalToolWindow (in category 'instance creation') ----- - prototypicalToolWindow - "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" - - ^ self methodBrowserSearchingFor: ''! Item was removed: - ----- Method: MessageNames>>buildSearchPaneWith: (in category 'toolbuilder') ----- - buildSearchPaneWith: builder - - | panelSpec textSpec buttonSpec | - panelSpec := builder pluggablePanelSpec new - layout: #horizontal; - children: OrderedCollection new; - yourself. - - textSpec := builder pluggableInputFieldSpec new. - textSpec - model: searchString; - help: 'Type here, then hit Search.' translated; - getText: #contents; - setText: #contents:; - softLineWrap: true. - panelSpec children add: textSpec. - - buttonSpec := builder pluggableActionButtonSpec new. - buttonSpec - model: self; - label: 'Search'; - action: #doSearch; - horizontalResizing: #shrinkWrap. - panelSpec children add: buttonSpec. - - ^ panelSpec! Item was removed: - ----- Method: MessageNames>>buildSelectorListWith: (in category 'toolbuilder') ----- - buildSelectorListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #selectorList; - getIndex: #selectorListIndex; - setIndex: #selectorListIndex:; - menu: #selectorListMenu:; - keyPress: #selectorListKey:from:. - ^listSpec - ! Item was removed: - ----- Method: MessageNames>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "ToolBuilder open: MessageNames new" - - | windowSpec max searchHeight | - max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5]. - searchHeight := Preferences standardDefaultTextFont height * 2. - - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 0.5 at 0.1) -> [self buildSearchPaneWith: builder]. - (0 at 0.1 corner: 0.5 @ max) -> [self buildSelectorListWith: builder]. - (0.5 at 0.0 corner: 1.0 at max) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - - ^ builder build: windowSpec! Item was removed: - ----- Method: MessageNames>>computeMessageList (in category 'search') ----- - computeMessageList - - ^ selectorListIndex = 0 - ifTrue: [#()] - ifFalse: [self systemNavigation - allImplementorsOf: (selectorList at: selectorListIndex)]! Item was removed: - ----- Method: MessageNames>>computeSelectorListFrom: (in category 'search') ----- - computeSelectorListFrom: searchString - "Compute selector list from search string. The searchString is a list of expressions separated by ;. Each expression is matched individually. An expression can be a simple string (same as *expression*), a string with double quotes (exact match) or a match expression (see String >> #match:)." - | selectors | - selectors := Set new. - (searchString findBetweenSubStrs: ';') do: - [ :selPat | - (selPat first = $" and: [ selPat last = $" and: [ selPat size > 2 ] ]) - ifTrue: - [(Symbol lookup: (selPat copyFrom: 2 to: selPat size - 1)) - ifNotNil: [ :sym | selectors add: sym ] ] - ifFalse: - [| n m | - n := selPat occurrencesOf: $*. - m := selPat occurrencesOf: $#. - selectors addAll: - (((n > 0 or: [ m > 0 ]) and: [ selPat size > (n + m) ]) - ifTrue: [ Symbol selectorsMatching: selPat ] - ifFalse: [ Symbol selectorsContaining: selPat ]) ] ]. - ^selectors sorted: [ :x :y | x caseInsensitiveLessOrEqual: y ]! Item was removed: - ----- Method: MessageNames>>copyName (in category 'message list menu') ----- - copyName - "Copy the current selector to the clipboard" - - | selector | - (selector := self selectorList at: selectorListIndex ifAbsent: [nil]) ifNotNil: - [Clipboard clipboardText: selector asString asText]! Item was removed: - ----- Method: MessageNames>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.639 g: 0.9 b: 0.497)! Item was removed: - ----- Method: MessageNames>>doSearch (in category 'search') ----- - doSearch - "The user hit the Search button -- treat it as a synonym for the user having hit the Return or Enter (or cmd-s) in the type-in pane" - - searchString changed: #acceptChanges.! Item was removed: - ----- Method: MessageNames>>doSearch: (in category 'search') ----- - doSearch: aSearchString - - | normalizedSearchString | - normalizedSearchString := aSearchString asString copyWithout: Character space. - - Cursor wait showWhile: [ - self selectorList: (self computeSelectorListFrom: normalizedSearchString)]. - - ^ true! Item was removed: - ----- Method: MessageNames>>frameOffsetFromTop:fromLeft:width:bottomFraction: (in category 'toolbuilder') ----- - frameOffsetFromTop: height fromLeft: leftFraction width: rightFraction bottomFraction: bottomFraction - ^LayoutFrame new - topFraction: 0 offset: height; - leftFraction: leftFraction offset: 0; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: bottomFraction offset: 0; - yourself.! Item was removed: - ----- Method: MessageNames>>initialize (in category 'initialization') ----- - initialize - - super initialize. - - searchString := ValueHolder new contents: ''. - searchString addDependent: self. - - selectorList := #(). - selectorListIndex := 0. - - self messageListIndex: 0.! Item was removed: - ----- Method: MessageNames>>labelString (in category 'initialization') ----- - labelString - - ^ self searchString - ifEmpty: ['Message Names'] - ifNotEmpty: [:s | 'Message names containing "', s asString asLowercase, '"']! Item was removed: - ----- Method: MessageNames>>mainSelectorListMenu: (in category 'selector list') ----- - mainSelectorListMenu: aMenu - "Answer the menu associated with the selectorList" - <selectorListMenu> - aMenu addList: #( - ('senders (n)' browseSenders 'browse senders of the chosen selector') - ('copy selector to clipboard' copyName 'copy the chosen selector to the clipboard, for subsequent pasting elsewhere') - - - ('show only implemented selectors' showOnlyImplementedSelectors 'remove from the selector-list all symbols that do not represent implemented methods')). - - ^ aMenu! Item was removed: - ----- Method: MessageNames>>messageList: (in category 'message list') ----- - messageList: someObjects - - messageList := someObjects. - self changed: #messageList. - - self messageListIndex: (messageList size > 0 - ifTrue: [1] - ifFalse: [0]).! Item was removed: - ----- Method: MessageNames>>postAcceptBrowseFor: (in category 'morphic ui') ----- - postAcceptBrowseFor: anotherModel - - self searchString: anotherModel searchString.! Item was removed: - ----- Method: MessageNames>>searchString (in category 'search') ----- - searchString - - ^ searchString contents! Item was removed: - ----- Method: MessageNames>>searchString: (in category 'search') ----- - searchString: aString - - searchString contents: aString.! Item was removed: - ----- Method: MessageNames>>selectedClassOrMetaClass (in category 'class list') ----- - selectedClassOrMetaClass - "Answer the currently selected class (or metaclass)." - self hasMessageSelected ifTrue: - [ ^ self setClassAndSelectorIn: [:c :s | ^c] ]. - - (selectorListIndex isNil not and: [selectorListIndex > 0]) ifTrue: [^Smalltalk classNamed: (self selectorList at: selectorListIndex)]. - - ^ nil. - ! Item was removed: - ----- Method: MessageNames>>selectedMessageName (in category 'message list') ----- - selectedMessageName - selectorList basicSize = 0 ifTrue: [^ nil]. "Deals with selectorList nil or empty" - ^selectorList at: (selectorListIndex max: 1) ifAbsent: [nil] "If no selection we can still find a selector"! Item was removed: - ----- Method: MessageNames>>selectorList (in category 'selector list') ----- - selectorList - - ^ selectorList! Item was removed: - ----- Method: MessageNames>>selectorList: (in category 'selector list') ----- - selectorList: someObjects - "Answer the selectorList" - - selectorList := someObjects. - self changed: #selectorList. - - "Select first result if any." - self selectorListIndex: (selectorList size > 0 - ifTrue: [1] - ifFalse: [0]).! Item was removed: - ----- Method: MessageNames>>selectorListFrame:fromTop: (in category 'toolbuilder') ----- - selectorListFrame: max fromTop: topOffset - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: topOffset; - rightFraction: 0.5 offset: 0; - bottomFraction: max offset: 0.! Item was removed: - ----- Method: MessageNames>>selectorListIndex (in category 'selector list') ----- - selectorListIndex - "Answer the selectorListIndex" - - ^ selectorListIndex! Item was removed: - ----- Method: MessageNames>>selectorListIndex: (in category 'selector list') ----- - selectorListIndex: anInteger - "Set the selectorListIndex as specified, and propagate consequences" - | methodClass index | - methodClass := currentCompiledMethod ifNotNil: [currentCompiledMethod methodClass]. - selectorListIndex := anInteger. - self changed: #selectorListIndex. - - messageList := self computeMessageList. - self changed: #messageList. - messageList size > 1 ifTrue: - [methodClass ifNotNil: [index := messageList findFirst: [:methodRef| methodRef actualClass = methodClass]]]. - - "If a method of the same class exists, select that, otherwise select the first message if any." - self messageListIndex: (index ifNil: [1 min: messageList size])! Item was removed: - ----- Method: MessageNames>>selectorListKey:from: (in category 'selector list') ----- - selectorListKey: aChar from: view - "Respond to a Command key in the message-list pane." - - aChar == $n ifTrue: [^ self browseSenders]. - aChar == $c ifTrue: [^ self copyName]. - aChar == $b ifTrue: [^ self browseMethodFull]. - ! Item was removed: - ----- Method: MessageNames>>selectorListMenu: (in category 'selector list') ----- - selectorListMenu: aMenu - "Answer the menu associated with the selectorList" - ^ self menu: aMenu for: #(selectorListMenu selectorListMenuShifted:) - ! Item was removed: - ----- Method: MessageNames>>selectorListMenuTitle (in category 'selector list') ----- - selectorListMenuTitle - "Answer the title to supply for the menu belonging to the selector-list pane" - - ^ 'Click on any item in the list - to see all implementors of it'! Item was removed: - ----- Method: MessageNames>>showOnlyImplementedSelectors (in category 'search') ----- - showOnlyImplementedSelectors - "Caution -- can be slow!! Filter my selector list down such that it only - shows selectors that are actually implemented somewhere in the system." - self okToChange ifFalse: [^ self]. - - Cursor wait showWhile: [ - self selectorList: (self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList)].! Item was removed: - ----- Method: MessageNames>>topConstantHeightFrame:fromLeft:width: (in category 'toolbuilder') ----- - topConstantHeightFrame: height fromLeft: leftFraction width: rightFraction - ^LayoutFrame new - topFraction: 0 offset: 0; - leftFraction: leftFraction offset: 0; - rightFraction: (leftFraction + rightFraction) offset: 0; - bottomFraction: 0 offset: height; - yourself.! Item was removed: - ----- Method: MessageNames>>update: (in category 'updating') ----- - update: aspect - - aspect == #contents - ifTrue: [ - self changed: #labelString. - self doSearch: self searchString]. - - super update: aspect.! Item was removed: - ----- Method: MessageNames>>windowTitle (in category 'toolbuilder') ----- - windowTitle - - ^ 'Message Names'! Item was removed: - CodeHolder subclass: #MessageSet - instanceVariableNames: 'growable messageList messageListFormatted autoSelectString messageListIndex editSelection windowLabel' - classVariableNames: 'UseUnifiedMessageLabels' - poolDictionaries: '' - category: 'Tools-Browser'! - - !MessageSet commentStamp: '<historical>' prior: 0! - I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.! Item was removed: - ----- Method: MessageSet class>>extantMethodsIn: (in category 'utilities') ----- - extantMethodsIn: aListOfMethodRefs - "Answer the subset of the incoming list consisting only of those message markers that refer to methods actually in the current image" - - - self flag: #mref. "may be removed in second round" - - - ^ aListOfMethodRefs select: [:aToken | - self - parse: aToken - toClassAndSelector: [ :aClass :aSelector | - aClass notNil and: [aClass includesSelector: aSelector] - ] - ]! Item was removed: - ----- Method: MessageSet class>>isPseudoSelector: (in category 'utilities') ----- - isPseudoSelector: aSelector - "Answer whether the given selector is a special marker" - - ^ #(Comment Definition Hierarchy) includes: aSelector! Item was removed: - ----- Method: MessageSet class>>messageList: (in category 'instance creation') ----- - messageList: anArray - "Answer an instance of me with message list anArray." - - ^self new initializeMessageList: anArray! Item was removed: - ----- Method: MessageSet class>>open:name: (in category 'instance creation') ----- - open: aMessageSet name: aString - "Create a standard system view for the messageSet, aMessageSet, whose label is aString." - ^ToolBuilder open: aMessageSet label: aString! Item was removed: - ----- Method: MessageSet class>>openMessageList:name: (in category 'instance creation') ----- - openMessageList: messageList name: labelString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - self openMessageList: messageList name: labelString autoSelect: nil! Item was removed: - ----- Method: MessageSet class>>openMessageList:name:autoSelect: (in category 'instance creation') ----- - openMessageList: messageList name: labelString autoSelect: autoSelectString - "Open a system view for a MessageSet on messageList. - The labelString is passed to the model to use as a base label, depending on the selection state" - - | messageSet | - messageSet := self messageList: messageList. - messageSet - autoSelectString: autoSelectString; - setInitialLabel: labelString. - ^ToolBuilder open: messageSet! Item was removed: - ----- Method: MessageSet class>>parse:toClassAndSelector: (in category 'utilities') ----- - parse: codeReferenceOrString toClassAndSelector: csBlock - "Decode strings of the form <className> [class] <selectorName>." - - | tuple cl | - codeReferenceOrString ifNil: [^ csBlock value: nil value: nil]. - codeReferenceOrString isCodeReference ifTrue: - [^codeReferenceOrString setClassAndSelectorIn: csBlock]. - codeReferenceOrString isEmpty ifTrue: - [^csBlock value: nil value: nil]. - tuple := (codeReferenceOrString asString includesSubstring: '>>') - ifTrue: [(codeReferenceOrString findTokens: '>>') fold: [:a :b| (a findTokens: ' '), {b first = $# ifTrue: [b allButFirst] ifFalse: [b]}]] - ifFalse: [codeReferenceOrString asString findTokens: ' .']. - self flag: #environments. "missing information about the class environment" - cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil]. - ^(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']]) - ifTrue: [csBlock value: cl value: (tuple at: 2) asSymbol] - ifFalse: [csBlock value: cl class value: (tuple at: 3) asSymbol]! Item was removed: - ----- Method: MessageSet class>>useUnifiedMessageLabels (in category 'preferences') ----- - useUnifiedMessageLabels - <preference: 'Use unified message labels' - categoryList: #(Tools tools) - description: 'In all message set browsers such as senders and implementors, show a unified, textual representation of all method references (or messages).' - type: #Boolean> - ^ UseUnifiedMessageLabels ifNil: [true]! Item was removed: - ----- Method: MessageSet class>>useUnifiedMessageLabels: (in category 'preferences') ----- - useUnifiedMessageLabels: aBoolean - - UseUnifiedMessageLabels := aBoolean.! Item was removed: - ----- Method: MessageSet>>aboutToStyle: (in category 'code pane') ----- - aboutToStyle: styler - "This is a notification that aPluggableShoutMorphOrView is about to re-style its text. - Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling." - - | selectedMessageName | - self isModeStyleable ifFalse: [^ false]. - - selectedMessageName := self selectedMessageName. - styler classOrMetaClass: self selectedClassOrMetaClass. - styler parseAMethod: (#(Comment Definition Hierarchy) includes: selectedMessageName) not. - ^ (#(Comment Hierarchy) includes: selectedMessageName) not! Item was removed: - ----- Method: MessageSet>>addExtraShiftedItemsTo: (in category 'message list') ----- - addExtraShiftedItemsTo: aMenu - "The shifted selector-list menu is being built. Add items specific to MessageSet" - self growable ifTrue: - [aMenu addList: #( - - - ('remove from this browser (d)' removeMessageFromBrowser) - ('filter message list...' filterMessageList))]. - aMenu - add: 'sort by date' - action: #sortByDate! Item was removed: - ----- Method: MessageSet>>addItem: (in category 'message list') ----- - addItem: classAndMethod - "Append a classAndMethod string to the list. Select the new item." - - "Do some checks on the input?" - self okToChange ifFalse: [^ self]. - messageList add: classAndMethod. - self changed: #messageList. - self messageListIndex: messageList size.! Item was removed: - ----- Method: MessageSet>>adjustWindowTitleAfterFiltering (in category 'private') ----- - adjustWindowTitleAfterFiltering - "Set the title of the receiver's window, if any, to reflect the just-completed filtering. Avoid re-doing it if fitering is re-done" - - (windowLabel endsWith: 'Filtered') - ifFalse: [windowLabel := windowLabel , ' Filtered'. - self changed: #windowTitle]! Item was removed: - ----- Method: MessageSet>>autoSelectString (in category 'private') ----- - autoSelectString - "Return the string to be highlighted when making new selections. For actual keyword selectors, only select the first keyword." - - ^ autoSelectString ifNotNil: [:stringOrSelector | - (Symbol lookup: stringOrSelector) - ifNil: [stringOrSelector "no change"] - ifNotNil: [:selector | selector precedence = 3 - "only the first part of the keyword message" - ifTrue: [selector copyFrom: 1 to: (selector indexOf: $:)] - "no change" - ifFalse: [stringOrSelector]]] - ! Item was removed: - ----- Method: MessageSet>>autoSelectString: (in category 'private') ----- - autoSelectString: aString - "Set the string to be highlighted when making new selections" - autoSelectString := aString! Item was removed: - ----- Method: MessageSet>>browseAllImplementorsOf: (in category 'message functions') ----- - browseAllImplementorsOf: selectorSymbol - self systemNavigation browseAllImplementorsOf: selectorSymbol! Item was removed: - ----- Method: MessageSet>>browseLocalSendersOfMessages (in category 'message functions') ----- - browseLocalSendersOfMessages - "Override so that if no method is selected it searches for senders local to the current list." - - self selectedClass ifNotNil: - [^super browseLocalSendersOfMessages]. - - self getSelectorAndSendQuery: #value:value: - to: [:literal :label| - self systemNavigation browseAllCallsOn: literal fromMethodReferences: messageList labelled: label] - with: { 'messages' }! Item was removed: - ----- Method: MessageSet>>buildMessageListWith: (in category 'toolbuilder') ----- - buildMessageListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #messageListFormatted; - getIndex: #messageListIndex; - setIndex: #messageListIndex:; - icon: #messageIconAt:; - helpItem: #messageHelpAt:; - menu: #messageListMenu:shifted:; - keyPress: #messageListKey:from:. - SystemBrowser browseWithDragNDrop ifTrue: [ - listSpec - dragItem: #dragFromMessageList:; - dragType: #dragTypeForMessageListAt:]. - ^ listSpec - ! Item was removed: - ----- Method: MessageSet>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - | windowSpec max result | - self wantsOptionalButtons ifTrue:[max := 0.3] ifFalse:[max := 0.3]. - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 1 at max) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - result := builder build: windowSpec. - autoSelectString ifNotNil:[self changed: #autoSelect]. - ^result! Item was removed: - ----- Method: MessageSet>>canShowMultipleMessageCategories (in category 'message category functions') ----- - canShowMultipleMessageCategories - "Answer whether the receiver is capable of showing multiple message categories" - - ^ false! Item was removed: - ----- Method: MessageSet>>changed: (in category 'updating') ----- - changed: aspect - - super changed: aspect. - - aspect = #messageList ifTrue: [ - messageListFormatted := nil. - self changed: #messageListFormatted].! Item was removed: - ----- Method: MessageSet>>classCommentIndicated (in category 'metaclass') ----- - classCommentIndicated - "Answer true iff we're viewing the class comment." - - ^ editSelection == #editComment or: [ self selectedMessageName == #Comment ]! Item was removed: - ----- Method: MessageSet>>contents (in category 'contents') ----- - contents - "Answer the contents of the receiver" - - ^ contents == nil - ifTrue: [currentCompiledMethod := nil. ''] - ifFalse: [self hasMessageSelected - ifTrue: [self editContents] - ifFalse: [currentCompiledMethod := nil. contents]]! Item was removed: - ----- Method: MessageSet>>contents:notifying: (in category 'private') ----- - contents: aString notifying: aController - "Compile the code in aString. Notify aController of any syntax errors. - Answer false if the compilation fails. Otherwise, if the compilation - created a new method, deselect the current selection. Then answer true." - - | category class oldSelector | - self okayToAccept ifFalse: [^ false]. - class := self targetForContents: aString. - class ifNil: [^ false]. - self setClassAndSelectorIn: [:c :os | oldSelector := os]. - (self contents: aString specialSelector: oldSelector in: class notifying: aController) - ifTrue: [^ false]. - "Normal method accept" - category := self selectedMessageCategoryName. - ^ self contents: aString - oldSelector: oldSelector - in: class - classified: category - notifying: aController! Item was removed: - ----- Method: MessageSet>>contents:oldSelector:in:classified:notifying: (in category 'private') ----- - contents: aString oldSelector: oldSelector in: aClass classified: category notifying: aController - "Compile the code in aString. Notify aController of any syntax errors. - Answer false if the compilation fails. Otherwise, if the compilation - created a new method, deselect the current selection. Then answer true." - | selector | - selector := aClass compile: aString - classified: category - notifying: aController. - selector == nil ifTrue: [^ false]. - self noteAcceptanceOfCodeFor: selector. - selector == oldSelector ifFalse: - [self reformulateListNoting: selector]. - contents := aString copy. - self changed: #annotation. - ^ true! Item was removed: - ----- Method: MessageSet>>contents:specialSelector:in:notifying: (in category 'private') ----- - contents: aString specialSelector: oldSelector in: aClass notifying: aController - "If the selector is a fake to denote a different definition than that of a method, - try to change that different object. Answer whether a special selector was found and - handled." - (oldSelector ~~ nil and: [oldSelector first isUppercase]) ifFalse: [^ false]. - oldSelector = #Comment ifTrue: - [aClass comment: aString stamp: Utilities changeStamp. - self changed: #annotation. - self clearUserEditFlag. - ^ true]. - oldSelector = #Definition ifTrue: - ["self defineClass: aString notifying: aController." - aClass subclassDefinerClass - evaluate: aString - notifying: aController - logged: true. - self clearUserEditFlag. - ^ true]. - oldSelector = #Hierarchy ifTrue: - [self inform: 'To change the hierarchy, edit the class definitions'. - ^ true]. - ^ false! Item was removed: - ----- Method: MessageSet>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.719 g: 0.9 b: 0.9)! Item was removed: - ----- Method: MessageSet>>deleteAllFromMessageList: (in category 'message functions') ----- - deleteAllFromMessageList: aCollection - "Delete the given messages from the receiver's message list" - | currIdx | - currIdx := self messageListIndex. - messageList := messageList copyWithoutAll: aCollection. - messageList ifNotEmpty: [self messageListIndex: {currIdx. messageList size.} min]! Item was removed: - ----- Method: MessageSet>>deleteFromMessageList: (in category 'message functions') ----- - deleteFromMessageList: aMessage - "Delete the given message from the receiver's message list" - | currIdx | - currIdx := self messageListIndex. - messageList := messageList copyWithout: aMessage. - messageList ifNotEmpty: [self messageListIndex: {currIdx. messageList size.} min]! Item was removed: - ----- Method: MessageSet>>deselectAll (in category 'private') ----- - deselectAll - self messageListIndex: 0! Item was removed: - ----- Method: MessageSet>>dragFromMessageList: (in category 'drag and drop') ----- - dragFromMessageList: index - - ^ self messageList at: index! Item was removed: - ----- Method: MessageSet>>dragTypeForMessageListAt: (in category 'drag and drop') ----- - dragTypeForMessageListAt: index - - ^ #sourceCode! Item was removed: - ----- Method: MessageSet>>editSelection: (in category 'accessing') ----- - editSelection: aSelection - "Set the editSelection as requested." - - editSelection := aSelection. - self changed: #editSelection.! Item was removed: - ----- Method: MessageSet>>fileOutMessage (in category 'message functions') ----- - fileOutMessage - "Put a description of the selected method on a file, or all methods if none selected." - - | fileName | - self selectedMessageName ifNotNil: - [^super fileOutMessage]. - fileName := UIManager default saveFilenameRequest: 'File out on which file?' initialAnswer: 'methods'. - fileName isEmptyOrNil ifTrue: [^self]. - Cursor write showWhile: - [| internalStream | - internalStream := WriteStream on: (String new: 1000). - internalStream header; timeStamp. - messageList do: - [:methodRef| - methodRef methodSymbol == #Comment - ifTrue: - [methodRef actualClass organization - putCommentOnFile: internalStream - numbered: 1 - moveSource: false - forClass: methodRef actualClass] - ifFalse: - [methodRef actualClass - printMethodChunk: methodRef methodSymbol - withPreamble: true - on: internalStream - moveSource: false - toFile: nil]]. - FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false]! Item was removed: - ----- Method: MessageSet>>filterFrom: (in category 'filtering') ----- - filterFrom: aBlock - "Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments." - - | newList | - newList := messageList select: - [:anElement | - self class parse: anElement toClassAndSelector: [ :cls :sel | - (self class isPseudoSelector: sel) not and: [ aBlock value: cls value: sel ]]]. - self setFilteredList: newList! Item was removed: - ----- Method: MessageSet>>filterMessageList (in category 'filtering') ----- - filterMessageList - "Allow the user to refine the list of messages." - | builder menuSpec | - builder := ToolBuilder default. - menuSpec := builder pluggableMenuSpec new - model: self; - yourself. - menuSpec addList: - #( - ('unsent messages' filterToUnsentMessages 'filter to show only messages that have no senders') - - - ('messages that send...' filterToSendersOf 'filter to show only messages that send a selector I specify') - ('messages that do not send...' filterToNotSendersOf 'filter to show only messages that do not send a selector I specify') - - - ('messages whose selector is...' filterToImplementorsOf 'filter to show only messages with a given selector I specify') - ('messages whose selector is NOT...' filterToNotImplementorsOf 'filter to show only messages whose selector is NOT a seletor I specify') - - - ('messages in current change set' filterToCurrentChangeSet 'filter to show only messages that are in the current change set') - ('messages not in current change set' filterToNotCurrentChangeSet 'filter to show only messages that are not in the current change set') - - - ('messages in any change set' filterToAnyChangeSet 'filter to show only messages that occur in at least one change set') - ('messages not in any change set' filterToNotAnyChangeSet 'filter to show only messages that do not occur in any change set in the system') - - - ('messages authored by me' filterToCurrentAuthor 'filter to show only messages whose authoring stamp has my initials') - ('messages not authored by me' filterToNotCurrentAuthor 'filter to show only messages whose authoring stamp does not have my initials') - - - ('messages logged in .changes file' filterToMessagesInChangesFile 'filter to show only messages whose latest source code is logged in the .changes file') - ('messages only in .sources file' filterToMessagesInSourcesFile 'filter to show only messages whose latest source code is logged in the .sources file') - - - ('messages with prior versions' filterToMessagesWithPriorVersions 'filter to show only messages that have at least one prior version') - ('messages without prior versions' filterToMessagesWithoutPriorVersions 'filter to show only messages that have no prior versions') - - - ('uncommented messages' filterToUncommentedMethods 'filter to show only messages that do not have comments at the beginning') - ('commented messages' filterToCommentedMethods 'filter to show only messages that have comments at the beginning') - - - ('messages in hardened classes' filterToMessagesWithHardenedClasses 'filter to show only messages of established classes (as opposed to Uniclasses such as Player23)') - - ('methods in classes with matching names' filterToMatchingClassesNames 'filter to show only methods of classes with names that match the given criteria (wildcards are allowed)') - ('methods in package...' filterToPackage 'filter to show only methods of a given package') - ('methods not in package...' filterToNotPackage 'filter to show only methods not of a given package') - - - ('messages that...' filterToMessagesThat 'let me type in a block taking a class and a selector, which will specify yea or nay concerning which elements should remain in the list')). - builder runModal: (builder open: menuSpec).! Item was removed: - ----- Method: MessageSet>>filterToAnyChangeSet (in category 'filtering') ----- - filterToAnyChangeSet - "Filter down only to messages present in ANY change set" - - self filterFrom: - [:aClass :aSelector | - ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector] - ! Item was removed: - ----- Method: MessageSet>>filterToCommentedMethods (in category 'filtering') ----- - filterToCommentedMethods - "Filter the receiver's list down to only those items which have comments" - - self filterFrom: - [:aClass :aSelector | - (aClass includesSelector: aSelector) and: - [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil not]]! Item was removed: - ----- Method: MessageSet>>filterToCurrentAuthor (in category 'filtering') ----- - filterToCurrentAuthor - "Filter down only to messages with my initials as most recent author" - self filterFrom: - [:aClass :aSelector | | aMethod aTimeStamp | - (aClass notNil and: [aSelector notNil]) and: - [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]. - aMethod notNil and: - [(aTimeStamp := aMethod timeStamp) notNil and: - [aTimeStamp beginsWith: Utilities authorInitials]]]]! Item was removed: - ----- Method: MessageSet>>filterToCurrentChangeSet (in category 'filtering') ----- - filterToCurrentChangeSet - "Filter the receiver's list down to only those items in the current change set" - - self filterFrom: - [:aClass :aSelector | - (aClass notNil and: [aSelector notNil]) and: - [(ChangeSet current atSelector: aSelector class: aClass) ~~ #none]]! Item was removed: - ----- Method: MessageSet>>filterToImplementorsOf (in category 'filtering') ----- - filterToImplementorsOf - "Filter the receiver's list down to only those items with a given selector" - - | aFragment inputWithBlanksTrimmed | - - aFragment := self request: 'type selector:' initialAnswer: ''. - aFragment isEmptyOrNil ifTrue: [^ self]. - inputWithBlanksTrimmed := aFragment withBlanksTrimmed. - (Symbol lookup: inputWithBlanksTrimmed) ifNotNil: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | - aSelector == aSymbol]]! Item was removed: - ----- Method: MessageSet>>filterToMatchingClassesNames (in category 'filtering') ----- - filterToMatchingClassesNames - - | reply | - - reply := UIManager default - request: 'Type the string to match' - initialAnswer: 'ClassName*' - centerAt: Sensor cursorPoint. - reply isEmptyOrNil ifTrue: [^ self]. - - self filterFrom: [:aClass :aSelector | reply match: aClass name asString] - ! Item was removed: - ----- Method: MessageSet>>filterToMessagesInChangesFile (in category 'filtering') ----- - filterToMessagesInChangesFile - "Filter down only to messages whose source code risides in the Changes file. This allows one to ignore long-standing methods that live in the .sources file." - - - self filterFrom: - [:aClass :aSelector | | cm | - aClass notNil and: [aSelector notNil and: - [(self class isPseudoSelector: aSelector) not and: - [(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and: - [cm fileIndex ~= 1]]]]]! Item was removed: - ----- Method: MessageSet>>filterToMessagesInSourcesFile (in category 'filtering') ----- - filterToMessagesInSourcesFile - "Filter down only to messages whose source code resides in the .sources file." - - - self filterFrom: [:aClass :aSelector | | cm | - (aClass notNil and: [aSelector notNil]) and: - [(self class isPseudoSelector: aSelector) not and: - [(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and: - [cm fileIndex = 1]]]]! Item was removed: - ----- Method: MessageSet>>filterToMessagesThat (in category 'filtering') ----- - filterToMessagesThat - "Allow the user to type in a block which will be" - - | reply | - reply := UIManager default - multiLineRequest: 'Type your block here' - centerAt: Sensor cursorPoint - initialAnswer: '[:aClass :aSelector | - - ]' - answerHeight: 200. - reply isEmptyOrNil ifTrue: [^ self]. - self filterFrom: (Compiler evaluate: reply) - ! Item was removed: - ----- Method: MessageSet>>filterToMessagesWithHardenedClasses (in category 'filtering') ----- - filterToMessagesWithHardenedClasses - "Filter the receiver's list down to only those items representing methods of hardened classes, as opposed to uniclasses" - - self filterFrom: - [:aClass :aSelector | - (aClass notNil and: [aSelector notNil]) and: - [aClass isUniClass not]]! Item was removed: - ----- Method: MessageSet>>filterToMessagesWithPriorVersions (in category 'filtering') ----- - filterToMessagesWithPriorVersions - "Filter down only to messages which have at least one prior version" - - self filterFrom: - [:aClass :aSelector | - (aClass notNil and: [aSelector notNil]) and: - [(self class isPseudoSelector: aSelector) not and: - [(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1]]]! Item was removed: - ----- Method: MessageSet>>filterToMessagesWithoutPriorVersions (in category 'filtering') ----- - filterToMessagesWithoutPriorVersions - "Filter down only to messages which have no prior version stored" - - self filterFrom: - [:aClass :aSelector | - (aClass notNil and: [aSelector notNil]) and: - [(self class isPseudoSelector: aSelector) not and: - [(VersionsBrowser versionCountForSelector: aSelector class: aClass) <= 1]]]! Item was removed: - ----- Method: MessageSet>>filterToNotAnyChangeSet (in category 'filtering') ----- - filterToNotAnyChangeSet - "Filter down only to messages present in NO change set" - - self filterFrom: - [:aClass :aSelector | - (ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector) not] - ! Item was removed: - ----- Method: MessageSet>>filterToNotCurrentAuthor (in category 'filtering') ----- - filterToNotCurrentAuthor - "Filter down only to messages not stamped with my initials" - self filterFrom: - [:aClass :aSelector | | aTimeStamp aMethod | - (aClass notNil and: [aSelector notNil]) and: - [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]. - aMethod notNil and: - [(aTimeStamp := aMethod timeStamp) isNil or: - [(aTimeStamp beginsWith: Utilities authorInitials) not]]]]! Item was removed: - ----- Method: MessageSet>>filterToNotCurrentChangeSet (in category 'filtering') ----- - filterToNotCurrentChangeSet - "Filter the receiver's list down to only those items not in the current change set" - - self filterFrom: - [:aClass :aSelector | - (aClass notNil and: [aSelector notNil]) and: - [(ChangeSet current atSelector: aSelector class: aClass) == #none]]! Item was removed: - ----- Method: MessageSet>>filterToNotImplementorsOf (in category 'filtering') ----- - filterToNotImplementorsOf - "Filter the receiver's list down to only those items whose selector is NOT one solicited from the user." - - | aFragment inputWithBlanksTrimmed | - - aFragment := self request: 'type selector: ' initialAnswer: ''. - aFragment isEmptyOrNil ifTrue: [^ self]. - inputWithBlanksTrimmed := aFragment withBlanksTrimmed. - (Symbol lookup: inputWithBlanksTrimmed) ifNotNil: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | - aSelector ~~ aSymbol]]! Item was removed: - ----- Method: MessageSet>>filterToNotPackage (in category 'filtering') ----- - filterToNotPackage - self requestPackageSelection ifNotNil: - [ : selectedPackage | self filterFrom: - [ : aClass : aSelector | (selectedPackage - includesMethod: aSelector - ofClass: aClass) not ] ]! Item was removed: - ----- Method: MessageSet>>filterToNotSendersOf (in category 'filtering') ----- - filterToNotSendersOf - "Filter the receiver's list down to only those items which do not send a given selector" - - | aFragment inputWithBlanksTrimmed | - - aFragment := self request: 'type selector:' initialAnswer: ''. - aFragment isEmptyOrNil ifTrue: [^ self]. - inputWithBlanksTrimmed := aFragment withBlanksTrimmed. - (Symbol lookup: inputWithBlanksTrimmed) ifNotNil: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | | aMethod | - (aMethod := aClass compiledMethodAt: aSelector) isNil or: - [(aMethod hasLiteral: aSymbol) not]]]! Item was removed: - ----- Method: MessageSet>>filterToPackage (in category 'filtering') ----- - filterToPackage - self requestPackageSelection ifNotNil: - [ : selectedPackage | self filterFrom: - [ : aClass : aSelector | selectedPackage - includesMethod: aSelector - ofClass: aClass ] ]! Item was removed: - ----- Method: MessageSet>>filterToSendersOf (in category 'filtering') ----- - filterToSendersOf - "Filter the receiver's list down to only those items which send a given selector" - - | aFragment inputWithBlanksTrimmed | - - aFragment := self request: 'type selector:' initialAnswer: ''. - aFragment isEmptyOrNil ifTrue: [^ self]. - inputWithBlanksTrimmed := aFragment withBlanksTrimmed. - (Symbol lookup: inputWithBlanksTrimmed) ifNotNil: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | | aMethod | - (aMethod := aClass compiledMethodAt: aSelector) notNil and: - [aMethod hasLiteral: aSymbol]]] - - ! Item was removed: - ----- Method: MessageSet>>filterToUncommentedMethods (in category 'filtering') ----- - filterToUncommentedMethods - "Filter the receiver's list down to only those items which lack comments" - - self filterFrom: - [:aClass :aSelector | - (aClass includesSelector: aSelector) and: - [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil]]! Item was removed: - ----- Method: MessageSet>>filterToUnsentMessages (in category 'filtering') ----- - filterToUnsentMessages - "Filter the receiver's list down to only those items which have no - senders" - self - filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]! Item was removed: - ----- Method: MessageSet>>formattedLabel: (in category 'message list') ----- - formattedLabel: aStringOrCodeReference - - self class parse: aStringOrCodeReference toClassAndSelector: [:cls :sel | - ^ self - formattedLabel: aStringOrCodeReference asString - forSelector: sel - inClass: cls]! Item was removed: - ----- Method: MessageSet>>growable (in category 'message list') ----- - growable - "Answer whether the receiver is capable of growing/shrinking dynamically" - - ^ growable ~~ false! Item was removed: - ----- Method: MessageSet>>growable: (in category 'message list') ----- - growable: aBoolean - "Give or take away the growable trait; when a message set is growable, methods submitted within it will be added to its message list" - - growable := aBoolean! Item was removed: - ----- Method: MessageSet>>hasMessageSelected (in category 'message list') ----- - hasMessageSelected - ^ messageListIndex ~= 0.! Item was removed: - ----- Method: MessageSet>>indentionPrefixOfSize: (in category 'indenting') ----- - indentionPrefixOfSize: levelInteger - - | answer | - answer := String new: levelInteger * self indentionSize. - answer atAllPut: $ . "space" - ^answer - ! Item was removed: - ----- Method: MessageSet>>indentionSize (in category 'indenting') ----- - indentionSize - - ^2 "that is, 2 spaces.." - ! Item was removed: - ----- Method: MessageSet>>indentionsIn: (in category 'indenting') ----- - indentionsIn: aString - - aString - withIndexDo: - [ :eachChar :index | - eachChar = $ "space" ifFalse: [ ^(index-1) / self indentionSize ] ]. - ^0 - ! Item was removed: - ----- Method: MessageSet>>initialize (in category 'initialize-release') ----- - initialize - - super initialize. - - messageList := OrderedCollection new. - windowLabel := ''.! Item was removed: - ----- Method: MessageSet>>initializeMessageList: (in category 'private') ----- - initializeMessageList: anArray - "Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses. - Do /not/ replace the elements of anArray if they are already MethodReferences, so as to allow users to construct richer systems, such as differencers between existing and edited versions of code. - NOTE THAT we must support anArray to already have the desired amount and order of elements such as for the 'method inheritance' view, where all elements are prefixed with spaces to indicate the inheritance tree." - - | isOrdered | - isOrdered := anArray size > 1 - and: [anArray second isMethodReference] - and: [anArray second stringVersion first = Character space]. - messageList := isOrdered - ifTrue: [OrderedCollection new] - ifFalse: [Set new]. - anArray do: - [:each | each isMethodReference - ifTrue: [messageList add: each] - ifFalse: - [ MessageSet - parse: each - toClassAndSelector: - [ : class : sel | class ifNotNil: [ messageList add: (MethodReference class: class selector: sel) ] ] ] ]. - isOrdered ifFalse: [messageList := messageList asOrderedCollection sort]. - "Unify labels if wanted." - self class useUnifiedMessageLabels ifTrue: - [ messageList withIndexDo: - [ : each : index | | cls | - cls := each actualClass. - each stringVersion: - (self indentionPrefixOfSize: (self indentionsIn: each stringVersion)) - , (cls - ifNil: [each asString] - ifNotNil: - [cls isUniClass - ifTrue: [cls typicalInstanceName, ' ', each selector] - ifFalse: - [ cls name , ' ' , each selector , ' {' - , ((cls organization categoryOfElement: each selector) ifNil: ['']) , '}' - , ' {', cls category, '}' ] ]) ] ]. - messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1]. - contents := String empty! Item was removed: - ----- Method: MessageSet>>isClassDefinition: (in category 'message list') ----- - isClassDefinition: messageListItemOrSymbol - "Answer whether this item from the message list (or its extracted selector) indicates a - class definition." - ^ messageListItemOrSymbol selector = #Definition! Item was removed: - ----- Method: MessageSet>>isComment: (in category 'message list') ----- - isComment: messageListItemOrSymbol - "Answer whether this item from the message list (or its extracted selector) indicates a - class comment." - ^ messageListItemOrSymbol selector = #Comment! Item was removed: - ----- Method: MessageSet>>isHierarchy: (in category 'message list') ----- - isHierarchy: messageListItemOrSymbol - "Answer whether this item from the message list (or its extracted selector) indicates a - class hierarchy." - ^ messageListItemOrSymbol selector = #Hierarchy! Item was removed: - ----- Method: MessageSet>>lastMessageName (in category 'message list') ----- - lastMessageName - ^ self messageList last selector.! Item was removed: - ----- Method: MessageSet>>mainMessageListMenu: (in category 'message list') ----- - mainMessageListMenu: aMenu - <messageListMenuShifted: false> - - ^ aMenu - addTranslatedList: #( - ('what to show...' offerWhatToShowMenu)); - add: (self isBreakOnEntry ifTrue: ['<on>'] ifFalse: ['<off>']) , 'break on entry' translated - action: #toggleBreakOnEntry; - addTranslatedList: #( - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseClassHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage) - ('printOut' printOutMessage) - ('copy selector (c)' copySelector) - ('copy reference (C)' copyReference) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('references... (r)' browseVariableReferences) - ('assignments... (a)' browseVariableAssignments) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage) - ('explore method' exploreMethod) - ('inspect method' inspectMethod)); - yourself! Item was removed: - ----- Method: MessageSet>>messageHelpAt: (in category 'message list') ----- - messageHelpAt: anIndex - "Show the first n lines of the sources code of the selected message." - - | reference | - Preferences balloonHelpInMessageLists ifFalse: [^ nil]. - self messageList size < anIndex ifTrue: [^ nil]. - - reference := self messageList at: anIndex. - reference isValid ifFalse: [^ nil]. - (self isComment: reference) ifTrue: [^ self messageHelpForComment: reference]. - (self isClassDefinition: reference) ifTrue: [^ self messageHelpForClassDefinition: reference]. - (self isHierarchy: reference) ifTrue: [^ self messageHelpForClassHierarchy: reference]. - ^ self messageHelpForMethod: reference compiledMethod! Item was removed: - ----- Method: MessageSet>>messageHelpForClassDefinition: (in category 'message list') ----- - messageHelpForClassDefinition: aMethodReference - "Answer the formatted help text for a class definition." - ^ aMethodReference setClassAndSelectorIn: [:class :sel | class definition]! Item was removed: - ----- Method: MessageSet>>messageHelpForClassHierarchy: (in category 'message list') ----- - messageHelpForClassHierarchy: aMethodReference - "Answer the formatted help text for a class hierarchy." - "Show the first n lines of the class hierarchy." - | source | - source := aMethodReference setClassAndSelectorIn: [:class :sel | class printHierarchy]. - ^ self messageHelpTruncated: source asText! Item was removed: - ----- Method: MessageSet>>messageHelpForComment: (in category 'message list') ----- - messageHelpForComment: aMethodReference - "Answer the formatted help text for a class comment." - "Show the first n lines of the class comment." - | source | - source := aMethodReference setClassAndSelectorIn: [:class :sel | class comment]. - ^ self messageHelpTruncated: source asText! Item was removed: - ----- Method: MessageSet>>messageIconAt: (in category 'message list') ----- - messageIconAt: anIndex - - Browser showMessageIcons - ifFalse: [^ nil]. - - ^ ToolIcons iconNamed: (ToolIcons - iconForClass: (self messageList at: anIndex) actualClass - selector: (self messageList at: anIndex) selector)! Item was removed: - ----- Method: MessageSet>>messageList (in category 'message list') ----- - messageList - "Answer the current list of messages." - - ^messageList! Item was removed: - ----- Method: MessageSet>>messageListFormatted (in category 'message list') ----- - messageListFormatted - - ^ messageListFormatted ifNil: [ - messageListFormatted := messageList collect: [:ea | self formattedLabel: ea]]! Item was removed: - ----- Method: MessageSet>>messageListIndex (in category 'message list') ----- - messageListIndex - ^messageListIndex ifNil: [0]! Item was removed: - ----- Method: MessageSet>>messageListIndex: (in category 'message list') ----- - messageListIndex: anInteger - "Set the index of the selected item to be anInteger. - Update the message list morph, the text edit morph and the assorted buttons" - - messageListIndex := anInteger. - contents := - messageListIndex ~= 0 - ifTrue: [self selectedMessage] - ifFalse: ['']. - self changed: #messageListIndex. "update my selection" - self editSelection: #editMessage. - self contentsChanged. - (messageListIndex ~= 0 and: [ autoSelectString notNil and: [ self contents notEmpty ] ]) ifTrue: [ self changed: #autoSelect ]. - self decorateButtons - ! Item was removed: - ----- Method: MessageSet>>messageListIndexOf: (in category 'message list') ----- - messageListIndexOf: aString - ^ (self messageList collect: [:each | each selector]) indexOf: aString.! Item was removed: - ----- Method: MessageSet>>messageListMenu:shifted: (in category 'message list') ----- - messageListMenu: aMenu shifted: shifted - "Answer the message-list menu" - ^ self menu: aMenu for: #(messageListMenu messageListMenuShifted:) shifted: shifted - ! Item was removed: - ----- Method: MessageSet>>messageListMenuHook:shifted: (in category 'pluggable menus - hooks') ----- - messageListMenuHook: aMenu shifted: aBoolean - <messageListMenu> - ^ self menuHook: aMenu named: #messageListMenu shifted: aBoolean. - ! Item was removed: - ----- Method: MessageSet>>metaClassIndicated (in category 'class list') ----- - metaClassIndicated - "Answer the boolean flag that indicates whether - this is a class method." - - ^ self selectedClassOrMetaClass isMeta! Item was removed: - ----- Method: MessageSet>>methodCategoryChanged (in category 'message functions') ----- - methodCategoryChanged - self changed: #annotation! Item was removed: - ----- Method: MessageSet>>modelWakeUp (in category 'user interface') ----- - modelWakeUp - "A window with me as model has been activated." - - super modelWakeUp. - (self canDiscardEdits and: [autoSelectString notNil]) ifTrue: [ - self codeTextMorph ifNotNil: [:tm | - (tm hasProperty: #launched) ifFalse: [ - tm scrollSelectionIntoView. - tm setProperty: #launched toValue: true] ] ]! Item was removed: - ----- Method: MessageSet>>optionalButtonHeight (in category 'message list') ----- - optionalButtonHeight - - ^ 15! Item was removed: - ----- Method: MessageSet>>reformulateList (in category 'message functions') ----- - reformulateList - "The receiver's messageList has been changed; rebuild it" - super reformulateList. - self - changed: #messageList ; - changed: #messageListIndex. - self contentsChanged. - autoSelectString ifNotNil: [ self changed: #autoSelect ]! Item was removed: - ----- Method: MessageSet>>removeMessage (in category 'message functions') ----- - removeMessage - - self hasMessageSelected ifFalse: [^ false]. - - super removeMessage ifFalse: [^ false]. - self deleteFromMessageList: self selection. - self reformulateList. - - ^ true! Item was removed: - ----- Method: MessageSet>>removeMessageFromBrowser (in category 'message functions') ----- - removeMessageFromBrowser - "Remove the selected message from the browser." - - self hasMessageSelected ifFalse: [^ self]. - self deleteFromMessageList: self selection. - self reformulateList. - self adjustWindowTitleAfterFiltering - ! Item was removed: - ----- Method: MessageSet>>representsSameBrowseeAs: (in category 'morphic ui') ----- - representsSameBrowseeAs: anotherModel - ^ self hasUnacceptedEdits not - and: [ messageList = anotherModel messageList ]! Item was removed: - ----- Method: MessageSet>>request:initialAnswer: (in category 'user interface') ----- - request: prompt initialAnswer: initialAnswer - - ^ UIManager default - request: prompt - initialAnswer: initialAnswer! Item was removed: - ----- Method: MessageSet>>requestPackageSelection (in category 'private') ----- - requestPackageSelection - | packages selectedIndex | - packages := PackageOrganizer default packages sort: - [ : a : b | a packageName <= b packageName ]. - selectedIndex := UIManager default - chooseFrom: (packages collect: [ : each | each packageName ]) - lines: Array empty - title: 'Select a package...'. - ^ packages at: selectedIndex ifAbsent: [ nil ]! Item was removed: - ----- Method: MessageSet>>selectedClass (in category 'class list') ----- - selectedClass - "Return the base class for the current selection. 1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected" - - | aClass | - ^ (aClass := self selectedClassOrMetaClass) == nil - ifTrue: - [nil] - ifFalse: - [aClass theNonMetaClass]! Item was removed: - ----- Method: MessageSet>>selectedClassName (in category 'class list') ----- - selectedClassName - "Answer the name of class of the currently selected message. Answer nil if no selection - exists." - - | cls | - (cls := self selectedClass) ifNil: [^ nil]. - ^ cls name! Item was removed: - ----- Method: MessageSet>>selectedClassOrMetaClass (in category 'class list') ----- - selectedClassOrMetaClass - "Answer the currently selected class (or metaclass)." - self hasMessageSelected ifFalse: [^nil]. - self setClassAndSelectorIn: [:c :s | ^c]! Item was removed: - ----- Method: MessageSet>>selectedMessage (in category 'message list') ----- - selectedMessage - "Answer the source method for the currently selected message." - - - self setClassAndSelectorIn: [:class :selector | | source | - class ifNil: [^ 'Class vanished']. - selector first isUppercase ifTrue: - [selector == #Comment ifTrue: - [currentCompiledMethod := class organization commentRemoteStr. - ^ class comment]. - selector == #Definition ifTrue: - [^ class definition]. - selector == #Hierarchy ifTrue: [^ class printHierarchy]]. - source := class sourceMethodAt: selector ifAbsent: - [currentCompiledMethod := nil. - ^ 'Missing']. - - self showingDecompile ifTrue: [^ self decompiledSourceIntoContents]. - - currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil]. - self showingDocumentation ifTrue: [^ self commentContents]. - - source := self sourceStringPrettifiedAndDiffed. - ^ source asText makeSelectorBoldIn: class]! Item was removed: - ----- Method: MessageSet>>selectedMessageCategoryName (in category 'class list') ----- - selectedMessageCategoryName - "Answer the name of the selected message category or nil." - | cls | - self hasMessageSelected ifFalse: [^ nil]. - cls := self selectedClassOrMetaClass. - - cls ifNil: [^ nil]. - - ^ cls organization categoryOfElement: self selectedMessageName! Item was removed: - ----- Method: MessageSet>>selectedMessageName (in category 'message list') ----- - selectedMessageName - "Answer the name of the currently selected message." - "wod 6/16/1998: answer nil if none are selected." - - messageListIndex = 0 ifTrue: [^ nil]. - ^ self setClassAndSelectorIn: [:class :selector | ^ selector]! Item was removed: - ----- Method: MessageSet>>selection (in category 'private') ----- - selection - "Answer the item in the list that is currently selected, or nil if no selection is present" - - ^ self messageList at: (self messageListIndex) ifAbsent: [nil]! Item was removed: - ----- Method: MessageSet>>setClassAndSelectorIn: (in category 'private') ----- - setClassAndSelectorIn: csBlock - "Decode strings of the form <className> [class] <selectorName>." - - | sel | - sel := self selection. - ^ sel isCodeReference - ifTrue: [sel setClassAndSelectorIn: csBlock] - ifFalse: [self class parse: sel toClassAndSelector: csBlock]! Item was removed: - ----- Method: MessageSet>>setContentsToForceRefetch (in category 'contents') ----- - setContentsToForceRefetch - "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" - - contents := ''! Item was removed: - ----- Method: MessageSet>>setFilteredList: (in category 'private') ----- - setFilteredList: newList - "Establish newList as the new list if appropriate, and adjust the window title accordingly; if the new list is of the same size as the old, warn and do nothing" - - | currentSelection | - newList size = 0 ifTrue: - [ self inform: 'Nothing would be left in the list if you did that'. - ^false ]. - newList size = messageList size ifTrue: - [ self inform: 'That leaves the list unchanged'. - ^false ]. - - messageListIndex > 0 ifTrue: - [currentSelection := messageList at: messageListIndex]. - - self - initializeMessageList: newList ; - adjustWindowTitleAfterFiltering. - - currentSelection ifNotNil: - [messageListIndex := messageList indexOf: currentSelection ifAbsent: [1]]. - - self - changed: #messageList; - changed: #messageListIndex. - - ^true! Item was removed: - ----- Method: MessageSet>>setInitialLabel: (in category 'accessing') ----- - setInitialLabel: aString - "set the base label for the window, as returned by #windowTitle" - - windowLabel := aString! Item was removed: - ----- Method: MessageSet>>shiftedMessageListMenu: (in category 'message list') ----- - shiftedMessageListMenu: aMenu - "Fill aMenu with the items appropriate when the shift key is held down" - <messageListMenuShifted: true> - - aMenu addStayUpItem. - aMenu addList: #( - ('toggle diffing (D)' toggleDiffing) - ('implementors of sent messages' browseAllMessages) - - - ('local senders of...' browseLocalSendersOfMessages) - ('local implementors of...' browseLocalImplementors) - - - ('spawn sub-protocol' spawnProtocol) - ('spawn full protocol' spawnFullProtocol) - - - ('sample instance' makeSampleInstance) - ('inspect instances' inspectInstances) - ('inspect subinstances' inspectSubInstances)). - - self addExtraShiftedItemsTo: aMenu. - aMenu addList: #( - - - ('change category...' changeCategory)). - - self canShowMultipleMessageCategories ifTrue: [aMenu addList: - #(('show category (C)' showHomeCategory))]. - aMenu addList: #( - - - ('change sets with this method' findMethodInChangeSets) - ('revert to previous version' revertToPreviousVersion) - ('remove from current change set' removeFromCurrentChanges) - ('revert & remove from changes' revertAndForget) - ('add to current change set' adoptMessageInCurrentChangeset) - ('copy up or copy down...' copyUpOrCopyDown)). - ^ aMenu - ! Item was removed: - ----- Method: MessageSet>>sortByDate (in category 'message list') ----- - sortByDate - "Sort the message-list by date of time-stamp" - - | associations | - associations := messageList collect: - [:aRef | | aDate aCompiledMethod | - aDate := aRef methodSymbol == #Comment - ifTrue: - [aRef actualClass organization dateCommentLastSubmitted] - ifFalse: - [aCompiledMethod := aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: [nil]. - aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]]. - aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history" - messageList := associations - sort: #value asSortFunction; - replace: [ :association | association key ]; - yourself. - self changed: #messageList! Item was removed: - ----- Method: MessageSet>>systemOrganizer: (in category 'initialize-release') ----- - systemOrganizer: aSystemOrganizer - - messageListIndex := 0. - ^ super systemOrganizer: aSystemOrganizer.! Item was removed: - ----- Method: MessageSet>>targetForContents: (in category 'private') ----- - targetForContents: aString - "Answer the behavior into which the contents will be accepted." - self setClassAndSelectorIn: [:c :os | ^ c]. - ^ nil "fail safe for overriding implementations of setClassAndSelectorIn:"! Item was removed: - ----- Method: MessageSet>>veryDeepInner: (in category 'copying') ----- - veryDeepInner: deepCopier - super veryDeepInner: deepCopier. - messageList := messageList veryDeepCopyWith: deepCopier. - editSelection := editSelection veryDeepCopyWith: deepCopier.! Item was removed: - ----- Method: MessageSet>>windowTitle (in category 'user interface') ----- - windowTitle - "just return the basic label for now" - - ^String streamContents: - [:str| str nextPutAll: windowLabel; - space; - nextPut: $[; - nextPutAll: messageList size asString; - nextPut: $] - ]! Item was removed: - MessageSet subclass: #MessageTrace - instanceVariableNames: 'autoSelectStrings messageSelections anchorIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !MessageTrace commentStamp: 'cmm 3/2/2010 20:26' prior: 0! - A MessageTrace is a MessageSet allowing efficient sender/implementor message following. With implementors indented below, and senders outdended above, message flow is succinctly expressed, hierarchically. - - My autoSelectStrings and messageSelections are Arrays of Booleans, parallel to my messageList. Each boolean indicates whether that message is selected. Each autoSelectStrings indicates which string should be highlighted in the code for each method in my messageList.! Item was removed: - ----- Method: MessageTrace class>>initialize (in category 'initializing') ----- - initialize - - self setUpPreferencesPanel! Item was removed: - ----- Method: MessageTrace class>>setUpPreferencesPanel (in category 'initializing') ----- - setUpPreferencesPanel - Preferences - addPreference: #traceMessages - category: #browsing - default: false - balloonHelp: 'If true, browsing senders or implementors in a methods browser will add to the methods in that browser instead of opening a new browser.' - ! Item was removed: - ----- Method: MessageTrace>>addChildMessages:autoSelectString: (in category 'building') ----- - addChildMessages: methodReferences autoSelectString: aString - | currentIndentionLevel addables selectables selectableString newAnchor | - selectableString := aString keywords - ifEmpty: [ String empty ] - ifNotEmptyDo: [ : keywords | - "we can probably do something more precise here; perhaps recombining the extracted keywords into a single selector? Then again all usages of this method seem to already enforce use of a selector" - aString ]. - [ (messageListIndex between: 1 and: autoSelectStrings size) ] - whileFalse: [ autoSelectStrings add: selectableString ]. - currentIndentionLevel := self currentIndentionLevel. - "Don't add mulitple copies of the same method, if a method is already in the list we will merely select it." - addables := methodReferences reject: [ : each | messageList includes: each ]. - addables do: - [ : each | - each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel + 1) , each asStringOrText. - messageList - add: each - afterIndex: self messageListIndex. - autoSelectStrings - add: nil - afterIndex: self messageListIndex. - messageSelections - add: false - afterIndex: self messageListIndex ]. - selectables := - addables copy - addAll: (methodReferences select: [ : each | messageList includes: each ]) ; - yourself. - self deselectAll. - anchorIndex := nil. - selectables do: - [ : each | - self - messageAt: (newAnchor := messageList indexOf: each) - beSelected: true. - anchorIndex ifNil: [ anchorIndex := newAnchor ] ]. - self changed: #messageList. - "Select the first child method." - self messageListIndex: - (selectables size > 0 - ifTrue: [ messageList indexOf: selectables last ] - ifFalse: [ messageList ifEmpty: [ 0 ] ifNotEmpty: [ 1 ] ])! Item was removed: - ----- Method: MessageTrace>>addChildMethodsNamed: (in category 'building') ----- - addChildMethodsNamed: selectorSymbol - - | methodsReferences | - - messageListIndex = 0 - ifTrue: - [ ^(PopUpMenu labels: ' OK ') - startUpWithCaption: 'Please reselect a method.' ]. - (methodsReferences := self filteredSelectorsNamed: selectorSymbol) isEmpty - ifTrue: - [ ^(PopUpMenu labels: ' OK ') - startUpWithCaption: 'There are no methods named ', selectorSymbol ] - ifFalse: - [ self - addChildMessages: methodsReferences - autoSelectString: selectorSymbol ] - ! Item was removed: - ----- Method: MessageTrace>>addExtraShiftedItemsTo: (in category 'message list') ----- - addExtraShiftedItemsTo: aMenu - "The shifted selector-list menu is being built. Add items specific to MessageTrace." - super addExtraShiftedItemsTo: aMenu. - aMenu addList: #(#('invert level selection (I)' #invertLevelSelection) )! Item was removed: - ----- Method: MessageTrace>>addParentMessages:autoSelectString: (in category 'building') ----- - addParentMessages: methodReferences autoSelectString: aString - | currentIndentionLevel addables selectables | - addables := methodReferences reject: [ : each | messageList includes: each ]. - "we may need to process aString here in a similar manner to that in #addChildMessages:autoSelectString:" - selectables := addables copy - addAll: (methodReferences select: [ : each | messageList includes: each ]) ; - yourself. - currentIndentionLevel := self currentIndentionLevel. - (currentIndentionLevel = 0 and: [ addables notEmpty ]) ifTrue: - [ self indentEverything. - currentIndentionLevel := 1 ]. - addables do: - [ : each | - each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel - 1) , each asStringOrText. - messageList - add: each - afterIndex: self messageListIndex - 1. - autoSelectStrings - add: aString - afterIndex: self messageListIndex - 1. - messageSelections - add: false - afterIndex: self messageListIndex - 1 ]. - self deselectAll. - selectables do: - [ : each | | messageIndex | - messageIndex := messageList indexOf: each. - self - messageAt: messageIndex - beSelected: true. - autoSelectStrings - at: messageIndex - put: aString ]. - self changed: #messageList. - anchorIndex := messageListIndex. - selectables size > 0 ifTrue: - [ self messageListIndex: (messageList indexOf: selectables first) ]! Item was removed: - ----- Method: MessageTrace>>addParentMethodsSending: (in category 'building') ----- - addParentMethodsSending: selectorSymbol - - | methodsList | - (methodsList := self systemNavigation allCallsOn: selectorSymbol) isEmpty - ifTrue: - [ ^(PopUpMenu labels: ' OK ') - startUpWithCaption: 'There are no methods that send ', selectorSymbol ] - ifFalse: - [ self - addParentMessages: methodsList - autoSelectString: selectorSymbol asString]! Item was removed: - ----- Method: MessageTrace>>autoSelectString: (in category 'building') ----- - autoSelectString: aString - - super autoSelectString: aString. - autoSelectStrings := messageList collect: [ :each | aString ] - ! Item was removed: - ----- Method: MessageTrace>>browseAllCallsOn:requestor: (in category 'actions') ----- - browseAllCallsOn: selectorSymbol requestor: anObject - "Overwritten to modify the trace if the request origins from a model-menu command such as the message-list menu (shortcut)." - - (selectorSymbol = self selectedMessageName - and: [ Preferences traceMessages ] and: [ self hasUnacceptedEdits not ]) - ifTrue: [ self addParentMethodsSending: selectorSymbol ] - ifFalse: [ super browseAllCallsOn: selectorSymbol requestor: anObject ].! Item was removed: - ----- Method: MessageTrace>>browseAllImplementorsOf:requestor: (in category 'actions') ----- - browseAllImplementorsOf: selectorSymbol requestor: anObject - "Overwritten to modify the trace if the request origins from a model-menu command such as the message-list menu (shortcut)." - - | selectorToBrowse | - selectorToBrowse := self selection - ifNil: [ selectorSymbol ] - ifNotNil: [ self getImplementorNamed: selectorSymbol asSymbol "since we can get passed literals"]. - (Preferences traceMessages and: [ self hasUnacceptedEdits not ]) - ifTrue: [ self addChildMethodsNamed: selectorToBrowse ] - ifFalse: [ super browseAllImplementorsOf: selectorToBrowse requestor: anObject ].! Item was removed: - ----- Method: MessageTrace>>buildMessageListWith: (in category 'private initializing') ----- - buildMessageListWith: builder - | listSpec | - listSpec := builder pluggableAlternateMultiSelectionListSpec new. - listSpec - model: self ; - list: #messageListFormatted ; - getIndex: #messageListIndex ; - setIndex: #toggleSelectionAt:shifted:controlled: ; - icon: #messageIconAt:; - helpItem: #messageHelpAt:; - menu: #messageListMenu:shifted: ; - getSelectionList: #isMessageSelectedAt: ; - setSelectionList: #messageAt:beSelected: ; - keyPress: #messageListKey:from:. - SystemBrowser browseWithDragNDrop - ifTrue: [ listSpec dragItem: #dragFromMessageList: ]. - ^ listSpec! Item was removed: - ----- Method: MessageTrace>>copySelector (in category 'menus') ----- - copySelector - Clipboard clipboardText: - (String streamContents: - [ : stream | self selectedMessages - do: [ : each | stream nextPutAll: each selector asString ] - separatedBy: [ stream space ] ])! Item was removed: - ----- Method: MessageTrace>>currentIndentionLevel (in category 'private accessing') ----- - currentIndentionLevel - ^ messageListIndex isZero ifFalse: [ self indentionLevelAt: messageListIndex ]! Item was removed: - ----- Method: MessageTrace>>deleteAllFromMessageList: (in category 'building') ----- - deleteAllFromMessageList: aCollection - "Delete the given messages from the receiver's message list" - - | newAutoSelectStrings newMessageSelections newSize set | - newSize := self messageList size - aCollection size. - newAutoSelectStrings := OrderedCollection new: newSize. - newMessageSelections := OrderedCollection new: newSize. - set := aCollection asSet. - self messageList withIndexDo: [:each :index | - (set includes: each) ifFalse: - [newAutoSelectStrings add: (autoSelectStrings at: index). - newMessageSelections add: (messageSelections at: index)]]. - super deleteAllFromMessageList: aCollection. - autoSelectStrings := newAutoSelectStrings. - messageSelections := newMessageSelections. - anchorIndex ifNotNil: - [ anchorIndex := anchorIndex min: messageList size ]! Item was removed: - ----- Method: MessageTrace>>deleteFromMessageList: (in category 'building') ----- - deleteFromMessageList: aMethodReference - "Delete the given message from the receiver's message list" - - | index | - autoSelectStrings removeAt: (index := messageList indexOf: aMethodReference). - messageSelections removeAt: index. - super deleteFromMessageList: aMethodReference. - anchorIndex ifNotNil: - [ anchorIndex := anchorIndex min: messageList size ] - ! Item was removed: - ----- Method: MessageTrace>>deselectAll (in category 'actions') ----- - deselectAll - super deselectAll. - 1 to: messageSelections size do: [ :index | messageSelections at: index put: false ] - ! Item was removed: - ----- Method: MessageTrace>>deselectAllBetweenLastSelectionAnd: (in category 'private actions') ----- - deselectAllBetweenLastSelectionAnd: indexPosition - - | lower higher | - lower := messageListIndex min: indexPosition. - higher := messageListIndex max: indexPosition. - lower = 0 ifTrue: [ ^nil ]. - lower to: higher do: - [ :index | messageSelections at: index put: false ] - ! Item was removed: - ----- Method: MessageTrace>>filterFrom: (in category 'filtering') ----- - filterFrom: aBlock - "Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments." - | newList newAutoSelectStrings newMessageSelections oldList | - oldList := Dictionary new. - messageList do: [ : each | oldList at: each put: each ]. - newList := messageList class new. - newAutoSelectStrings := autoSelectStrings class new. - newMessageSelections := messageSelections class new. - messageList withIndexDo: - [ : each : index | (self class - parse: each - toClassAndSelector: aBlock) ifTrue: - [ newList add: each. - newAutoSelectStrings add: (autoSelectStrings at: index). - newMessageSelections add: (messageSelections at: index) ] ]. - (self setFilteredList: newList) ifTrue: - [ autoSelectStrings := newAutoSelectStrings. - messageList do: - [ : each | each stringVersion: (oldList at: each) asString ] ]! Item was removed: - ----- Method: MessageTrace>>filteredSelectorsNamed: (in category 'filtering') ----- - filteredSelectorsNamed: selectorSymbol - - ^(SystemNavigation for: self environment) allImplementorsOf: selectorSymbol - ! Item was removed: - ----- Method: MessageTrace>>getImplementorNamed: (in category 'private accessing') ----- - getImplementorNamed: selectorSymbol - | allPossibilities | - allPossibilities := (((self selection compiledMethod messages - select: [ :eachSelector | eachSelector beginsWith: selectorSymbol ]) - copyWith: selectorSymbol) - select: [ :each | (Symbol lookup: each) notNil ]) - asSet asOrderedCollection sort. - (allPossibilities includes: selectorSymbol) ifTrue: - [ allPossibilities addFirst: (allPossibilities remove: selectorSymbol) ]. - ^allPossibilities size > 1 - ifTrue: - [ | selectionIndex | - selectionIndex := (PopUpMenu labelArray: allPossibilities lines: #(1)) - startUpWithCaption: - 'Browse implementors of - which message?'. - selectionIndex = 0 ifTrue: [ selectorSymbol ] ifFalse: [ allPossibilities at: selectionIndex ] ] - ifFalse: [ allPossibilities isEmpty - ifTrue: [ selectorSymbol ] - ifFalse: [ allPossibilities first ] ] - ! Item was removed: - ----- Method: MessageTrace>>indentEverything (in category 'indenting') ----- - indentEverything - - messageList do: [ :each | each stringVersion: (self indentionPrefixOfSize: 1), each asString ] - ! Item was removed: - ----- Method: MessageTrace>>indentionLevelAt: (in category 'private accessing') ----- - indentionLevelAt: msgListIndex - ^ self indentionsIn: (messageList at: msgListIndex) asString! Item was removed: - ----- Method: MessageTrace>>initialize (in category 'private initializing') ----- - initialize - - super initialize. - messageSelections := OrderedCollection new. - autoSelectStrings := OrderedCollection new - ! Item was removed: - ----- Method: MessageTrace>>initializeMessageList: (in category 'private initializing') ----- - initializeMessageList: anArray - super initializeMessageList: anArray. - messageSelections := (Array new: messageList size withAll: false) asOrderedCollection. - self - messageAt: messageListIndex - beSelected: true. - "autoSelectStrings is initialized right after this method, in autoSelectString:" - ! Item was removed: - ----- Method: MessageTrace>>invertLevelSelection (in category 'actions') ----- - invertLevelSelection - "The user wants to be able to quickly and easily assemble message-traces. When browsing senders or implementors of a heavily overloaded selector, typically just one or two messages are relevant out of several. In that situation, the user need merely select the range of relevant methods to arrive within two gestures of trimming the irrelevant methods: Command+I (capital eye) to invert the selection within the local group followed by Command+d to remove that selection from the browser." - | index currentLevel start | - currentLevel := self currentIndentionLevel ifNil: - [ | possibilities | - possibilities := ((1 to: messageSelections size) select: - [ : idx | messageSelections at: idx ]) collect: - [ : eachSelectedIndex | self indentionLevelAt: eachSelectedIndex ]. - possibilities asSet size > 1 - ifTrue: [ ^ self ] - ifFalse: - [ possibilities ifEmpty: [ ^ self ]. - start := messageSelections indexOf: true. - possibilities anyOne ] ]. - "First invert at messageListIndex then crawl up and down from there until a different level is reached, inverting as we go." - messageListIndex > 0 ifTrue: [ start := messageListIndex ]. - self toggleMessageSelectionAt: start. - index := start. - [ index := index - 1. - index > 0 and: [ (self indentionLevelAt: index) = currentLevel ] ] whileTrue: [ self toggleMessageSelectionAt: index ]. - index := start. - [ index := index + 1. - index <= messageList size and: [ (self indentionLevelAt: index) = currentLevel ] ] whileTrue: [ self toggleMessageSelectionAt: index ]. - self - messageListIndex: 0 ; - changed: #messageList! Item was removed: - ----- Method: MessageTrace>>isMessageSelectedAt: (in category 'testing') ----- - isMessageSelectedAt: anInteger - - ^messageSelections at: anInteger ifAbsent: [ false ]! Item was removed: - ----- Method: MessageTrace>>messageAt:beSelected: (in category 'actions') ----- - messageAt: indexInteger beSelected: aBoolean - ^ indexInteger isZero ifFalse: - [ messageSelections - at: indexInteger - put: aBoolean ]! Item was removed: - ----- Method: MessageTrace>>messageListIndex: (in category 'actions') ----- - messageListIndex: anInteger - "Set the index of the selected item to be anInteger. - Find the relevant auto select string to use, do my superclass' work and update the window title" - - autoSelectStrings ifNotEmpty: - [ autoSelectString := - anInteger = 0 - ifTrue: [ "clear the autoSelectString" - String empty ] - ifFalse: [autoSelectStrings at: anInteger] - ]. - - anInteger > 0 ifTrue: [ self - messageAt: anInteger - beSelected: true - ]. - super messageListIndex: anInteger. - self changed: #windowTitle - ! Item was removed: - ----- Method: MessageTrace>>messageListKey:from: (in category 'message list') ----- - messageListKey: aChar from: view - aChar == $I ifTrue: [ ^ self invertLevelSelection ]. - ^ super messageListKey: aChar from: view! Item was removed: - ----- Method: MessageTrace>>noteSelectionIndex:for: (in category 'accessing') ----- - noteSelectionIndex: anInteger for: aSymbol - aSymbol == #messageList - ifTrue: - [ messageListIndex := anInteger. - self - messageAt: messageListIndex - beSelected: true ]. - super - noteSelectionIndex: anInteger - for: aSymbol! Item was removed: - ----- Method: MessageTrace>>removeFromCurrentChanges (in category 'message list') ----- - removeFromCurrentChanges - "Tell the changes mgr to forget that the selected messages were changed." - - self selectedMessages do: [:each | - each setClassAndSelectorIn: [:class :selector | - ChangeSet current removeSelectorChanges: selector class: class]]. - self changed: #annotation! Item was removed: - ----- Method: MessageTrace>>removeMessage (in category 'actions') ----- - removeMessage - "Remove the selected messages from the system." - self selectedMessages size = 0 ifTrue: [ ^self ]. - self selectedMessages size = 1 ifTrue: [ ^super removeMessage ]. - (self confirm: ('Are you certain you want to remove all the {1} selected methods from the image?' translated format: {self selectedMessages size})) ifFalse: [ ^self ]. - self selectedMessages do: - [ :each | - each actualClass removeSelector: each methodSymbol. - self deleteFromMessageList: each ]! Item was removed: - ----- Method: MessageTrace>>removeMessageFromBrowser (in category 'building') ----- - removeMessageFromBrowser - | indexToSelect | - "Try to keep the same selection index." - indexToSelect := (messageSelections indexOf: true) max: 1. - self deleteAllFromMessageList: self selectedMessages. - self deselectAll. - messageSelections ifNotEmpty: - [ messageSelections - at: (indexToSelect min: messageSelections size) "safety" - put: true ]. - anchorIndex := indexToSelect min: messageSelections size. - self - messageListIndex: anchorIndex ; - reformulateList! Item was removed: - ----- Method: MessageTrace>>selectAllBetweenAnchorAnd: (in category 'private actions') ----- - selectAllBetweenAnchorAnd: indexPosition - - | lower higher | - self deselectAllBetweenLastSelectionAnd: indexPosition. - anchorIndex ifNil: [ anchorIndex := indexPosition ]. - lower := anchorIndex min: indexPosition. - higher := anchorIndex max: indexPosition. - lower to: higher do: - [ :index | messageSelections at: index put: true ] - ! Item was removed: - ----- Method: MessageTrace>>selectedMessages (in category 'private actions') ----- - selectedMessages - - | answer | - answer := OrderedCollection new. - messageSelections withIndexDo: - [ :eachSelection :index | - eachSelection ifTrue: [ answer add: (messageList at: index) ] ]. - ^answer - ! Item was removed: - ----- Method: MessageTrace>>toggleMessageSelectionAt: (in category 'private actions') ----- - toggleMessageSelectionAt: anInteger - - messageSelections - at: anInteger - put: (messageSelections at: anInteger) not - ! Item was removed: - ----- Method: MessageTrace>>toggleSelectionAt: (in category 'actions') ----- - toggleSelectionAt: currentPosition - "Compatibility with MVC" - - ^ self - toggleSelectionAt: currentPosition - shifted: false - controlled: false! Item was removed: - ----- Method: MessageTrace>>toggleSelectionAt:shifted:controlled: (in category 'actions') ----- - toggleSelectionAt: anInteger shifted: isShifted controlled: isMouseDragging - anInteger = 0 ifTrue: [ ^ nil ]. - (isMouseDragging not and: [anInteger = anchorIndex and: [ (messageSelections occurrencesOf: true) = 1 ]]) - ifTrue: - [ self toggleMessageSelectionAt: anInteger. - anchorIndex := nil. - self messageListIndex: 0 ] - ifFalse: - [ self deselectAll. - isShifted - ifTrue: [ self selectAllBetweenAnchorAnd: anInteger ] - ifFalse: - [ self - messageAt: anInteger - beSelected: true. - anchorIndex := anInteger ]. - self messageListIndex: anInteger ]! Item was removed: - ----- Method: MessageTrace>>veryDeepInner: (in category 'copying') ----- - veryDeepInner: aDeepCopier - super veryDeepInner: aDeepCopier. - autoSelectStrings := autoSelectStrings veryDeepCopyWith: aDeepCopier. - messageSelections := messageSelections veryDeepCopyWith: aDeepCopier! Item was removed: - ----- Method: MessageTrace>>windowLabelAt: (in category 'private accessing') ----- - windowLabelAt: anInteger - "return a suitable window label when there is an actual list item selected; work out what it should be based upon the array of autoSelectStrings or the current selection" - - ^(autoSelectStrings at: anInteger) - ifNil: - ['Implementors of ', - (self class - parse: self selection - toClassAndSelector: [ :class :selector | selector ])] - ifNotNil: - [:str| (windowLabel endsWith: str) - ifTrue: [windowLabel] - ifFalse: ['Senders of ', str]]! Item was removed: - ----- Method: MessageTrace>>windowTitle (in category 'building') ----- - windowTitle - "set the window label to suit the selection state; - if no selection, use saved widow label and add the number of items in the messageList - if something is selected, use the relevant string provided by windowLabelAt: which considers the index" - - ^messageListIndex = 0 - ifTrue:[String streamContents: [:str| str nextPutAll: windowLabel; - space; - nextPut: $[; - nextPutAll: messageList size asString; - nextPut: $] - ] - ] - ifFalse: [self windowLabelAt: messageListIndex]! Item was removed: - Object subclass: #MethodFinder - instanceVariableNames: 'data answers selector argMap thisData mapStage mapList expressions cachedClass cachedArgNum cachedSelectorLists' - classVariableNames: 'AddAndRemove Approved Blocks Dangerous' - poolDictionaries: '' - category: 'Tools-MethodFinder'! - - !MethodFinder commentStamp: '<historical>' prior: 0! - Find a method in the system from a set of examples. Done by brute force, trying every possible selector. Errors are skipped over using ( [3 + 'xyz'] ifError: [^ false] ). - Submit an array of the form ((data1 data2) answer (data1 data2) answer). - - MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10). - - answer: 'data1 + data2' - - More generally, use the brace notation to construct live examples. - - The program tries data1 as the receiver, and - tries all other permutations of the data for the receiver and args, and - tries leaving out one argument, and - uses all selectors data understands, and - uses all selectors in all od data's superclasses. - - Floating point values must be precise to 0.01 percent, or (X * 0.0001). - - If you get an error, you have probably discovered a selector that needs to be removed from the Approved list. See MethodFinder.initialize. Please email the Squeak Team. - - Only considers 0, 1, 2, and 3 argument messages. The argument data may have 1 to 5 entries, but only a max of 4 used at a time. For now, we only test messages that use given number of args or one fewer. For example, this data (100 true 0.6) would test the receiver plus two args, and the receiver plus one arg, but not any other patterns. - - Three sets of selectors: Approved, AddAndRemove, and Blocks selectors. When testing a selector in AddAndRemove, deepCopy the receiver. We do not handle selectors that modify an argument (printOn: etc.). Blocks is a set of (selector argNumber) where that argument must be a block. - - For perform, the selector is tested. It must be in the Approved list. - - do: is not on the Approved list. It does not produce a result that can be tested. Type 'do' into the upper pane of the Selector Finder to find messages list that. - - [Later, allow the user to supply a block that tests the answer, not just the literal answer.] - MethodFinder methodFor: { { true. [3]. [4]}. 3}. - Later allow this to work without the blocks around 3 and 4.! Item was removed: - ----- Method: MethodFinder class>>cleanUp: (in category 'class initialization') ----- - cleanUp: aggressive - - Approved := nil. - AddAndRemove := nil. - Blocks := nil.! Item was removed: - ----- Method: MethodFinder class>>methodFor: (in category 'utility') ----- - methodFor: dataAndAnswers - "Return a Squeak expression that computes these answers. (This method is called by the comment in the bottom pane of a MethodFinder. Do not delete this method.)" - - | resultOC resultString | - resultOC := (self new) load: dataAndAnswers; findMessage. - resultString := String streamContents: [:strm | - resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]]. - ^ resultString! Item was removed: - ----- Method: MethodFinder>>allNumbers (in category 'find a constant') ----- - allNumbers - "Return true if all answers and all data are numbers." - - answers do: [:aa | aa isNumber ifFalse: [^ false]]. - thisData do: [:vec | - vec do: [:nn | nn isNumber ifFalse: [^ false]]]. - ^ true! Item was removed: - ----- Method: MethodFinder>>answers (in category 'access') ----- - answers - - ^ answers! Item was removed: - ----- Method: MethodFinder>>argMap (in category 'arg maps') ----- - argMap - ^ argMap ! Item was removed: - ----- Method: MethodFinder>>cleanInputs: (in category 'initialize') ----- - cleanInputs: dataAndAnswerString - "Find an remove common mistakes. Complain when ill formed." - - | fixed ddd rs places | - ddd := dataAndAnswerString. - fixed := false. - - rs := ReadStream on: ddd, ' '. - places := OrderedCollection new. - [rs upToAll: '#true'. rs atEnd] whileFalse: [places addFirst: rs position-4]. - places do: [:pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''. - fixed := true]. "remove #" - - rs := ReadStream on: ddd. - places := OrderedCollection new. - [rs upToAll: '#false'. rs atEnd] whileFalse: [places addFirst: rs position-5]. - places do: [:pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''. - fixed := true]. "remove #" - - fixed ifTrue: [self inform: '#(true false) are Symbols, not Booleans. - Next time use { true. false }.']. - - fixed := false. - rs := ReadStream on: ddd. - places := OrderedCollection new. - [rs upToAll: '#nil'. rs atEnd] whileFalse: [places addFirst: rs position-3]. - places do: [:pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''. - fixed := true]. "remove #" - - fixed ifTrue: [self inform: '#nil is a Symbol, not the authentic UndefinedObject. - Next time use nil instead of #nil']. - - ^ ddd - ! Item was removed: - ----- Method: MethodFinder>>const (in category 'find a constant') ----- - const - | const | - "See if (^ constant) is the answer" - - "quick test" - ((const := answers at: 1) closeTo: (answers at: 2)) ifFalse: [^ false]. - 3 to: answers size do: [:ii | (const closeTo: (answers at: ii)) ifFalse: [^ false]]. - expressions add: '^ ', const printString. - selector add: #yourself. - ^ true! Item was removed: - ----- Method: MethodFinder>>constDiv (in category 'find a constant') ----- - constDiv - | const subTest got | - "See if (data1 // C) is the answer" - - const := ((thisData at: 1) at: 1) // (answers at: 1). "May not be right!!" - got := (subTest := MethodFinder new copy: self addArg: const) - searchForOne isEmpty not. - got ifFalse: [^ false]. - - "replace data2 with const in expressions" - subTest expressions do: [:exp | - expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. - selector addAll: subTest selectors. - ^ true! Item was removed: - ----- Method: MethodFinder>>constEquiv (in category 'find a constant') ----- - constEquiv - | const subTest got jj | - "See if (data1 = C) or (data1 ~= C) is the answer" - - "quick test" - ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. - 2 to: answers size do: [:ii | - ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. - - const := (thisData at: 1) at: 1. - got := (subTest := MethodFinder new copy: self addArg: const) - searchForOne isEmpty not. - got ifFalse: ["try other polarity for ~~ " - (jj := answers indexOf: (answers at: 1) not) > 0 ifTrue: [ - const := (thisData at: jj) at: 1. - got := (subTest := MethodFinder new copy: self addArg: const) - searchForOne isEmpty not]]. - got ifFalse: [^ false]. - - "replace data2 with const in expressions" - subTest expressions do: [:exp | - expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. - selector addAll: subTest selectors. - ^ true! Item was removed: - ----- Method: MethodFinder>>constLinear (in category 'find a constant') ----- - constLinear - | const subTest got denom num slope offset | - "See if (data1 * C1) + C2 is the answer. In the form #(C2 C1) polynomialEval: data1 " - - denom := ((thisData at: 2) at: 1) - ((thisData at: 1) at: 1). - denom = 0 ifTrue: [^ false]. "will divide by it" - num := (answers at: 2) - (answers at: 1). - - slope := (num asFloat / denom) reduce. - offset := ((answers at: 2) - (((thisData at: 2) at: 1) * slope)) reduce. - - const := Array with: offset with: slope. - got := (subTest := MethodFinder new copy: self addArg: const) - searchForOne isEmpty not. - got ifFalse: [^ false]. - - "replace data2 with const in expressions" - subTest expressions do: [:exp | - expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. - selector addAll: subTest selectors. - ^ true! Item was removed: - ----- Method: MethodFinder>>constMod (in category 'find a constant') ----- - constMod - | subTest low | - "See if mod, (data1 \\ C) is the answer" - - low := answers max. - low+1 to: low+20 do: [:const | - subTest := MethodFinder new copy: self addArg: const. - (subTest testPerfect: #\\) ifTrue: [ - expressions add: 'data1 \\ ', const printString. - selector add: #\\. - ^ true]]. - ^ false! Item was removed: - ----- Method: MethodFinder>>constMult (in category 'find a constant') ----- - constMult - | const subTest got | - "See if (data1 * C) is the answer" - - ((thisData at: 1) at: 1) = 0 ifTrue: [^ false]. - const := ((answers at: 1) asFloat / ((thisData at: 1) at: 1)) reduce. - got := (subTest := MethodFinder new copy: self addArg: const) - searchForOne isEmpty not. - got ifFalse: [^ false]. - - "replace data2 with const in expressions" - subTest expressions do: [:exp | - expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. - selector addAll: subTest selectors. - ^ true! Item was removed: - ----- Method: MethodFinder>>constPlus (in category 'find a constant') ----- - constPlus - | const subTest got | - "See if (data1 + C) is the answer" - - const := (answers at: 1) - ((thisData at: 1) at: 1). - got := (subTest := MethodFinder new copy: self addArg: const) - searchForOne isEmpty not. - got ifFalse: [^ false]. - - "replace data2 with const in expressions" - subTest expressions do: [:exp | - expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. - selector addAll: subTest selectors. - ^ true! Item was removed: - ----- Method: MethodFinder>>constUsingData1Value (in category 'find a constant') ----- - constUsingData1Value - | subTest | - "See if (data1 <= C) or (data1 >= C) is the answer" - - "quick test" - ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. - 2 to: answers size do: [:ii | - ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. - - thisData do: [:datums | | got const | - const := datums first. "use data as a constant!!" - got := (subTest := MethodFinder new copy: self addArg: const) - searchForOne isEmpty not. - got ifTrue: [ - "replace data2 with const in expressions" - subTest expressions do: [:exp | - expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. - selector addAll: subTest selectors. - ^ true]]. - ^ false! Item was removed: - ----- Method: MethodFinder>>copy:addArg: (in category 'initialize') ----- - copy: mthFinder addArg: aConstant - | more | - "Copy inputs and answers, add an additional data argument to the inputs. The same constant for every example" - - more := Array with: aConstant. - data := mthFinder data collect: [:argList | argList, more]. - answers := mthFinder answers. - self load: nil. - ! Item was removed: - ----- Method: MethodFinder>>data (in category 'access') ----- - data - - ^ data! Item was removed: - ----- Method: MethodFinder>>exceptions (in category 'search') ----- - exceptions - "Handle some very slippery selectors. - asSymbol -- want to be able to produce it, but do not want to make every string submitted into a Symbol!!" - - | aSel | - answers first isSymbol ifFalse: [^ self]. - thisData first first isString ifFalse: [^ self]. - aSel := #asSymbol. - (self testPerfect: aSel) ifTrue: [ - selector add: aSel. - expressions add: (String streamContents: [:strm | - strm nextPutAll: 'data', argMap first printString. - aSel keywords withIndexDo: [:key :ind | - strm nextPutAll: ' ',key. - (key last == $:) | (key first isLetter not) - ifTrue: [strm nextPutAll: ' data', - (argMap at: ind+1) printString]]])]. - ! Item was removed: - ----- Method: MethodFinder>>expressions (in category 'access') ----- - expressions - ^ expressions! Item was removed: - ----- Method: MethodFinder>>findMessage (in category 'search') ----- - findMessage - "Control the search." - - data do: [:alist | - (alist isKindOf: SequenceableCollection) ifFalse: [ - ^ OrderedCollection with: 'first and third items are not Arrays']]. - Approved ifNil: [self initialize]. "Sets of allowed selectors" - expressions := OrderedCollection new. - self search: true. "multi" - expressions isEmpty ifTrue: [^ OrderedCollection with: 'no single method does that function']. - expressions isString ifTrue: [^ OrderedCollection with: expressions]. - ^ expressions! Item was removed: - ----- Method: MethodFinder>>initialize (in category 'initialize') ----- - initialize - "The methods we are allowed to use. (MethodFinder new initialize) " - - Approved := Set new. - AddAndRemove := Set new. - Blocks := Set new. - "These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:" - - "Object" - #("in class, instance creation" categoryForUniclasses chooseUniqueClassName initialInstance isSystemDefined newFrom: officialClass readCarefullyFrom: - "accessing" at: basicAt: basicSize bindWithTemp: in: size yourself - "testing" basicType ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps - "comparing" = == closeTo: hash identityHash identityHashPrintString ~= ~~ - "copying" copy shallowCopy - "dependents access" canDiscardEdits dependents hasUnacceptedEdits - "updating" changed changed: okToChange update: windowIsClosing - "printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation - "class membership" class isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass - "error handling" - "user interface" addModelMenuItemsTo:forMorph:hand: defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: newTileMorphRepresentative windowActiveOnFirstClick windowReqNewLabel: - "system primitives" asOop instVarAt: instVarNamed: - "private" - "associating" -> - "converting" as: asOrderedCollection asString - "casing" caseOf: caseOf:otherwise: - "binding" bindingOf: - "macpal" contentsChanged currentEvent currentHand currentWorld flash instanceVariableValues scriptPerformer - "flagging" flag: - "translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel]. - #(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:" - "message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: - ) do: [:sel | AddAndRemove add: sel]. - - "Boolean, True, False, UndefinedObject" - #("logical operations" & eqv: not xor: | - "controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or: - "copying" - "testing" isEmptyOrNil) do: [:sel | Approved add: sel]. - - "Behavior" - #("initialize-release" - "accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass - "testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords - "copying" - "printing" defaultNameStemForInstances printHierarchy - "creating class hierarchy" - "creating method dictionary" - "instance creation" basicNew basicNew: new new: - "accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses - "accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent: - "accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames - "testing class hierarchy" inheritsFrom: kindOfSubclass - "testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichMethodsStoreInto: - "enumerating" - "user interface") do: [:sel | Approved add: sel]. - - "ClassDescription" - #("initialize-release" - "accessing" classVersion isMeta name theNonMetaClass - "copying" - "printing" classVariablesString instanceVariablesString sharedPoolsString - "instance variables" checkForInstVarsOK: - "method dictionary" - "organization" category organization whichCategoryIncludesSelector: - "compiling" acceptsLoggingOfCompilation wantsChangeSetLogging - "fileIn/Out" definition - "private" ) do: [:sel | Approved add: sel]. - - "Class" - #("initialize-release" - "accessing" classPool - "testing" - "copying" - "class name" - "instance variables" - "class variables" classVarAt: classVariableAssociationAt: - "pool variables" - "compiling" - "subclass creation" - "fileIn/Out" ) do: [:sel | Approved add: sel]. - - "Metaclass" - #("initialize-release" - "accessing" isSystemDefined soleInstance - "copying" "instance creation" "instance variables" "pool variables" "class hierarchy" "compiling" - "fileIn/Out" nonTrivial ) do: [:sel | Approved add: sel]. - - "Context, BlockContext" - #(receiver client method receiver tempAt: - "debugger access" pc selector sender shortStack sourceCode tempNames tempsAndValues - "controlling" "printing" "system simulation" - "initialize-release" - "accessing" hasMethodReturn home numArgs - "evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments: - "controlling" "scheduling" "instruction decoding" "printing" "private" "system simulation" ) do: [:sel | Approved add: sel]. - #(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel]. - - "Message" - #("inclass, instance creation" selector: selector:argument: selector:arguments: - "accessing" argument argument: arguments sends: - "printing" "sending" ) do: [:sel | Approved add: sel]. - #("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel]. - - "Magnitude" - #("comparing" < <= > >= between:and: - "testing" max: min: min:max: ) do: [:sel | Approved add: sel]. - - "Date, Time" - #("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today - "in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth: - "accessing" day leap monthIndex monthName weekday year - "arithmetic" addDays: subtractDate: subtractDays: - "comparing" - "inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous: - "converting" asSeconds - "printing" mmddyyyy printFormat: - "private" weekdayIndex - "in class, instance creation" fromSeconds: now - "in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds - "accessing" hours minutes seconds - "arithmetic" addTime: subtractTime: - "comparing" - "printing" intervalString print24 - "converting") do: [:sel | Approved add: sel]. - #("private" - ) do: [:sel | AddAndRemove add: sel]. - - "Number" - #("in class" readFrom:base: - "arithmetic" * + - / // \\ abs negated quo: reciprocal rem: - "mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan - "truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated - "comparing" - "testing" even isDivisibleBy: isInfinite isNaN isZero negative odd positive sign strictlyPositive - "converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees - "intervals" to: to:by: - "printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel]. - - "Integer" - #("in class" primesUpTo: - "testing" isPowerOfTwo - "arithmetic" alignedTo: - "comparing" - "truncation and round off" atRandom normalize - "enumerating" timesRepeat: - "mathematical functions" degreeCos degreeSin factorial gcd: lcm: take: - "bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask: - "converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit - "printing" asStringWithCommas hex hex8 radix: - "system primitives" lastDigit replaceFrom:to:with:startingAt: - "private" "benchmarks" ) do: [:sel | Approved add: sel]. - - "SmallInteger, LargeNegativeInteger, LargePositiveInteger" - #("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" - "system primitives" digitAt: digitLength - "private" fromString:radix: ) do: [:sel | Approved add: sel]. - #(digitAt:put: ) do: [:sel | AddAndRemove add: sel]. - - "Float" - #("arithmetic" - "mathematical functions" reciprocalLogBase2 timesTwoPower: - "comparing" "testing" - "truncation and round off" exponent fractionPart integerPart significand significandAsInteger - "converting" asApproximateFraction asIEEE32BitWord asTrueFraction - "copying") do: [:sel | Approved add: sel]. - - "Fraction, Random" - #(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel]. - #(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel]. - - "Collection" - #("accessing" anyOne - "testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf: - "enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection: - "converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection: - "printing" - "private" maxSize - "arithmetic" - "math functions" average max median min range sum) do: [:sel | Approved add: sel]. - #("adding" add: addAll: addIfNotPresent: - "removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel]. - - "SequenceableCollection" - #("comparing" hasEqualElements: - "accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third - "removing" - "copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sorted: - "enumerating" withIndexCollect: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval: - "converting" asArray asDictionary asFloat32Array asFloat64Array asIntegerArray asStringWithCr asWordArray reversed - "private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel]. - #( swap:with:) do: [:sel | AddAndRemove add: sel]. - - "ArrayedCollection, Bag" - #("private" defaultElement - "sorting" isSorted - "accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" - ) do: [:sel | Approved add: sel]. - #( mergeSortFrom:to:by: sort sort: add: add:withOccurrences: - "private" setDictionary ) do: [:sel | AddAndRemove add: sel]. - - "Other messages that modify the receiver" - #(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with: removeFirst removeLast) do: [:sel | AddAndRemove add: sel]. - - self initialize2. - - " - MethodFinder new initialize. - MethodFinder new organizationFiltered: Set - " - - ! Item was removed: - ----- Method: MethodFinder>>initialize2 (in category 'initialize') ----- - initialize2 - "The methods we are allowed to use. (MethodFinder new initialize) " - - "Set" - #("in class" sizeFor: - "testing" "adding" "removing" "enumerating" - "private" array scanFor: - "accessing" someElement) do: [:sel | Approved add: sel]. - - "Dictionary, IdentityDictionary, IdentitySet" - #("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys - "testing" includesKey: ) do: [:sel | Approved add: sel]. - #(removeKey: removeKey:ifAbsent: - ) do: [:sel | AddAndRemove add: sel]. - - "LinkedList, Interval, MappedCollection" - #("in class" from:to: from:to:by: - "accessing" contents) do: [:sel | Approved add: sel]. - #( - "adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel]. - - "OrderedCollection, SortedCollection" - #("accessing" after: before: - "copying" copyEmpty - "adding" growSize - "removing" "enumerating" "private" - "accessing" sortBlock) do: [:sel | Approved add: sel]. - #("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast: - "removing" removeAt: removeFirst removeLast - "accessing" sortBlock:) do: [:sel | AddAndRemove add: sel]. - - "Character" - #("in class, instance creation" allByteCharacters digitValue: new separators - "accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab - "constants" alphabet characterTable - "accessing" asciiValue digitValue - "comparing" - "testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish - "copying" - "converting" asIRCLowercase asLowercase asUppercase - ) do: [:sel | Approved add: sel]. - - "String" - #("in class, instance creation" crlf fromPacked: - "primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: "internet" valueOfHtmlEntity: - "accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubstring: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit - "comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt: - "copying" copyReplaceTokens:with: padded:to:with: - "converting" asByteArray asDate asDisplayText asFileName asHtml asLegalSelector asPacked asParagraph asText asTime asUnHtml asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks - "displaying" "printing" - "system primitives" compare:with:collated: - "Celeste" withCRs - "internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting - "testing" isAllSeparators lastSpacePosition - "paragraph support" indentationIfBlank: - "arithmetic" ) do: [:sel | Approved add: sel]. - #(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel]. - - "Symbol" - #("in class, private" hasInterned:ifTrue: - "access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping: - "accessing" "comparing" "copying" "converting" "printing" - "testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel]. - - "Array" - #("comparing" "converting" evalStrings - "printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel]. - - "Array2D" - #("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel]. - #(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel]. - - "ByteArray" - #("accessing" doubleWordAt: wordAt: - "platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: - "converting") do: [:sel | Approved add: sel]. - #(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian: - ) do: [:sel | AddAndRemove add: sel]. - - "FloatArray" "Dont know what happens when prims not here" - false ifTrue: [#("accessing" "arithmetic" *= += -= /= - "comparing" - "primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar: - "primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to: - "converting" "private" "user interface") do: [:sel | Approved add: sel]. - ]. - - "IntegerArray, WordArray" - "RunArray" - #("in class, instance creation" runs:values: scanFrom: - "accessing" runLengthAt: - "adding" "copying" - "private" runs values) do: [:sel | Approved add: sel]. - #(coalesce repeatLast:ifEmpty: repeatLastIfEmpty: - ) do: [:sel | AddAndRemove add: sel]. - - "Stream -- many operations change its state" - #("testing" atEnd) do: [:sel | Approved add: sel]. - #("accessing" next: nextMatchAll: nextMatchFor: upToEnd - next:put: nextPut: nextPutAll: "printing" print: printHtml: - ) do: [:sel | AddAndRemove add: sel]. - - "PositionableStream" - #("accessing" contentsOfEntireFile originalContents peek peekFor: "testing" - "positioning" position ) do: [:sel | Approved add: sel]. - #(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel]. - "Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics. We want to find the messages that convert Streams to other things." - - "ReadWriteStream" - #("file status" closed) do: [:sel | Approved add: sel]. - #("accessing" next: on: ) do: [:sel | AddAndRemove add: sel]. - - "WriteStream" - #("in class, instance creation" on:from:to: with: with:from:to: - ) do: [:sel | Approved add: sel]. - #("positioning" resetToStart - "character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel]. - - "LookupKey, Association, Link" - #("accessing" key nextLink) do: [:sel | Approved add: sel]. - #(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel]. - - "Point" - #("in class, instance creation" r:degrees: x:y: - "accessing" x y "comparing" "arithmetic" "truncation and round off" - "polar coordinates" degrees r theta - "point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector - "converting" asFloatPoint asIntegerPoint corner: extent: rect: - "transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying" - "interpolating" interpolateTo:at:) do: [:sel | Approved add: sel]. - - "Rectangle" - #("in class, instance creation" center:extent: encompassing: left:right:top:bottom: - merging: origin:corner: origin:extent: - "accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight - "comparing" - "rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth: - "testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide - "truncation and round off" - "transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying" - ) do: [:sel | Approved add: sel]. - - "Color" - #("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range: - "named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow - "other" colorNames indexedColors pixelScreenForDepth: quickHighLight: - "access" alpha blue brightness green hue luminance red saturation - "equality" - "queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor - "transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with: - "groups of shades" darkShades: lightShades: mix:shades: wheel: - "printing" shortPrintString - "other" colorForInsets rgbTriplet - "conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32 - "private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying" - ) do: [:sel | Approved add: sel]. - - " For each selector that requires a block argument, add (selector argNum) - to the set Blocks." - "ourClasses := #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color). - ourClasses do: [:clsName | cls := Smalltalk at: clsName. - (cls selectors) do: [:aSel | - ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ - (cls formalParametersAt: aSel) withIndexDo: [:tName :ind | - (tName endsWith: 'Block') ifTrue: [ - Blocks add: (Array with: aSel with: ind)]]]]]. - " - #((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFal se:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sorted: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray | - Blocks add: anArray]. - - self initialize3. - - " - MethodFinder new initialize. - MethodFinder new organizationFiltered: TranslucentColor class - " - "Do not forget class messages for each of these classes" - ! Item was removed: - ----- Method: MethodFinder>>initialize3 (in category 'initialize') ----- - initialize3 - "additional selectors to consider" - - #(asWords threeDigitName ) do: [:sel | Approved add: sel].! Item was removed: - ----- Method: MethodFinder>>insertConstants (in category 'search') ----- - insertConstants - "see if one of several known expressions will do it. C is the constant we discover here." - "C data1+C data1*C data1//C (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C) - (data1 mod C)" - - thisData size >= 2 ifFalse: [^ false]. "need 2 examples" - (thisData at: 1) size = 1 ifFalse: [^ false]. "only one arg, data1" - - self const ifTrue: [^ true]. - self constUsingData1Value ifTrue: [^ true]. - "(data1 ?? const), where const is one of the values of data1" - " == ~~ ~= = <= >= " - - self allNumbers ifFalse: [^ false]. - self constMod ifTrue: [^ true]. - self constPlus ifTrue: [^ true]. - self constMult ifTrue: [^ true]. - self constDiv ifTrue: [^ true]. - self constLinear ifTrue: [^ true]. - ^ false! Item was removed: - ----- Method: MethodFinder>>load: (in category 'initialize') ----- - load: dataWithAnswers - "Find a function that takes the data and gives the answers. Odd list entries are data for it, even ones are the answers. nil input means data and answers were supplied already." - " (MethodFinder new) load: #( (4 3) 7 (-10 5) -5 (-3 11) 8); - findMessage " - - dataWithAnswers ifNotNil: [ - data := Array new: dataWithAnswers size // 2. - 1 to: data size do: [:ii | data at: ii put: (dataWithAnswers at: ii*2-1)]. - answers := Array new: data size. - 1 to: answers size do: [:ii | answers at: ii put: (dataWithAnswers at: ii*2)]]. - data do: [:list | - (list isKindOf: SequenceableCollection) ifFalse: [ - ^ self inform: 'first and third items are not Arrays']. - ]. - argMap := (1 to: data first size) asArray. - data do: [:list | list size = argMap size ifFalse: [ - self inform: 'data arrays must all be the same size']]. - argMap size > 4 ifTrue: [self inform: 'No more than a receiver and - three arguments allowed']. - "Really only test receiver and three args." - thisData := data copy. - mapStage := mapList := nil. - ! Item was removed: - ----- Method: MethodFinder>>makeAllMaps (in category 'arg maps') ----- - makeAllMaps - "Make a giant list of all permutations of the args. To find the function, we will try these permutations of the input data. receiver, args." - - | ii | - mapList := Array new: argMap size factorial. - ii := 1. - argMap permutationsDo: [:perm | - mapList at: ii put: perm copy. - ii := ii + 1]. - mapStage := 1. "about to be bumped"! Item was removed: - ----- Method: MethodFinder>>mapData (in category 'arg maps') ----- - mapData - "Force the data through the map (permutation) to create the data to test." - - thisData := data collect: [:realData | - argMap collect: [:ind | realData at: ind]]. - ! Item was removed: - ----- Method: MethodFinder>>noteDangerous (in category 'initialize') ----- - noteDangerous - "Remember the methods with really bad side effects." - - Dangerous := Set new. - "Object accessing, testing, copying, dependent access, macpal, flagging" - #(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit) - do: [:sel | Dangerous add: sel]. - - "Object error handling" - #(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility) - do: [:sel | Dangerous add: sel]. - - "Object user interface" - #(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement ) - do: [:sel | Dangerous add: sel]. - - "Object system primitives" - #(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:) - do: [:sel | Dangerous add: sel]. - - "Object private" - #(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:) - do: [:sel | Dangerous add: sel]. - - "Object, translation support" - #(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:) - do: [:sel | Dangerous add: sel]. - - "Object, objects from disk, finalization. And UndefinedObject" - #(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until: suspend) - do: [:sel | Dangerous add: sel]. - - "No Restrictions: Boolean, False, True, " - - "Morph" - #() - do: [:sel | Dangerous add: sel]. - - "Behavior" - #(obsolete confirmRemovalOf: copyOfMethodDictionary storeLiteral:on: addSubclass: removeSubclass: superclass: - "creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo: - "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables - "private" flushCache format:variable:words:pointers: format:variable:words:pointers:weak: format:variable:bitsUnitSize:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:) - do: [:sel | Dangerous add: sel]. - - "CompiledMethod" - #(defaultSelector) - do: [:sel | Dangerous add: sel]. - - "Others " - #("no tangible result" do: associationsDo: - "private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser) - do: [:sel | Dangerous add: sel]. - - - #( fileOutPrototype addSpareFields makeFileOutFile ) - do: [:sel | Dangerous add: sel]. - #(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: instanceVariableNames: ) - do: [:sel | Dangerous add: sel]. - - ! Item was removed: - ----- Method: MethodFinder>>organizationFiltered: (in category 'initialize') ----- - organizationFiltered: aClass - "Return the organization of the class with all selectors defined in superclasses removed. (except those in Object)" - - | org str | - org := aClass organization deepCopy. - Dangerous do: [:sel | - org removeElement: sel]. - Approved do: [:sel | - org removeElement: sel]. - AddAndRemove do: [:sel | - org removeElement: sel]. - str := org printString copyWithout: $(. - str := '(', (str copyWithout: $) ). - str := str replaceAll: $' with: $". - ^ str - ! Item was removed: - ----- Method: MethodFinder>>permuteArgs (in category 'arg maps') ----- - permuteArgs - "Run through ALL the permutations. First one was as presented." - - data first size <= 1 ifTrue: [^ false]. "no other way" - mapList ifNil: [self makeAllMaps]. - mapStage := mapStage + 1. - mapStage > mapList size ifTrue: [^ false]. - argMap := mapList at: mapStage. - self mapData. - ^ true - ! Item was removed: - ----- Method: MethodFinder>>search: (in category 'search') ----- - search: multi - "if Multi is true, collect all selectors that work." - selector := OrderedCollection new. "list of them" - self simpleSearch. - multi not & (selector isEmpty not) ifTrue:[^ selector]. - - [self permuteArgs] whileTrue: - [self simpleSearch. - multi not & (selector isEmpty not) ifTrue: [^ selector]]. - - self insertConstants. - "(selector isEmpty not) ifTrue: [^ selector]]. expression is the answer, not a selector" - ^ #()! Item was removed: - ----- Method: MethodFinder>>searchForOne (in category 'search') ----- - searchForOne - "Look for and return just one answer" - - expressions := OrderedCollection new. - self search: false. "non-multi" - ^ expressions - ! Item was removed: - ----- Method: MethodFinder>>selectors (in category 'access') ----- - selectors - "Note the inst var does not have an S on the end" - - ^ selector! Item was removed: - ----- Method: MethodFinder>>simpleSearch (in category 'search') ----- - simpleSearch - "Run through first arg's class' selectors, looking for one that works." - - | class supers listOfLists | - self exceptions. - class := thisData first first class. - "Cache the selectors for the receiver class" - (class == cachedClass and: [cachedArgNum = ((argMap size) - 1)]) - ifTrue: [listOfLists := cachedSelectorLists] - ifFalse: [supers := class withAllSuperclasses. - listOfLists := OrderedCollection new. - supers do: [:cls | - listOfLists add: (cls selectorsWithArgs: (argMap size) - 1)]. - cachedClass := class. - cachedArgNum := (argMap size) - 1. - cachedSelectorLists := listOfLists]. - listOfLists do: [:selectorList | - selectorList do: [:aSel | - (selector includes: aSel) ifFalse: [ - ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ - (self testPerfect: aSel) ifTrue: [ - selector add: aSel. - expressions add: (String streamContents: [:strm | - strm nextPutAll: 'data', argMap first printString. - aSel keywords withIndexDo: [:key :ind | - strm nextPutAll: ' ',key. - (key last == $:) | (key first isLetter not) - ifTrue: [strm nextPutAll: ' data', - (argMap at: ind+1) printString]]]) - ]]]]]. - ! Item was removed: - ----- Method: MethodFinder>>test2: (in category 'initialize') ----- - test2: anArray - "look for bad association" - - anArray do: [:sub | - sub class == Association ifTrue: [ - (#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [ - self error: 'bad assn']. - (#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [ - self error: 'bad assn']. - ]. - sub class == Array ifTrue: [ - sub do: [:element | - element isString ifTrue: [element first asciiValue < 32 ifTrue: [ - self error: 'store into string in data']]. - element class == Association ifTrue: [ - element value class == Association ifTrue: [ - self error: 'bad assn']]]]. - sub class == Date ifTrue: [sub year isInteger ifFalse: [ - self error: 'stored into input date!!!!']]. - sub class == Dictionary ifTrue: [ - sub size > 0 ifTrue: [ - self error: 'store into dictionary']]. - sub class == OrderedCollection ifTrue: [ - sub size > 4 ifTrue: [ - self error: 'store into OC']]. - ].! Item was removed: - ----- Method: MethodFinder>>test3 (in category 'initialize') ----- - test3 - "find the modification of the caracter table" - - (#x at: 1) asciiValue = 120 ifFalse: [self error: 'Character table mod'].! Item was removed: - ----- Method: MethodFinder>>testFromTuple: (in category 'initialize') ----- - testFromTuple: nth - "verify that the methods allowed don't crash the system. Try N of each of the fundamental types. up to 4 of each kind." - - | objects nonRepeating even other aa cnt | - objects := #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four') - (x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3) - ). - - objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}. - {Point class. SmallInteger class. Association class. Array class}. - "{ 4 blocks }." - {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}. - {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}. - {Dictionary new. Dictionary new. Dictionary new. Dictionary new}. - {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. - #($a 3 d) asOrderedCollection. #() asOrderedCollection}. - {3 -> true. 5.6 -> $a. #x -> 2. 'abcd' -> false}. - {9 @ 3 extent: 5 @ 4. 0 @ 0 extent: 45 @ 9. -3 @ -7 extent: 2 @ 2. 4 @ 4 extent: 16 @ 16}. - {Color red. Color blue. Color black. Color gray}}. - - self test2: objects. - "rec+0, rec+1, rec+2, rec+3 need to be tested. " - cnt := 0. - nth to: 4 do: [:take | - nonRepeating := OrderedCollection new. - objects do: [:each | - nonRepeating addAll: (each copyFrom: 1 to: take)]. - "all combinations of take, from nonRepeating" - even := true. - nonRepeating combinations: take atATimeDo: [:tuple | - even ifTrue: [other := tuple shallowCopy] - ifFalse: [self load: (aa := Array with: tuple with: 1 with: other with: 7). - (cnt := cnt + 1) \\ 50 = 0 ifTrue: [ - Transcript cr; show: aa first printString]. - self search: true. - self test2: aa. - self test2: nonRepeating. - "self test2: objects"]. - even := even not]. - ].! Item was removed: - ----- Method: MethodFinder>>testPerfect: (in category 'search') ----- - testPerfect: aSelector - "Try this selector!! Return true if it answers every example perfectly. Take the args in the order they are. Do not permute them. Survive errors. later cache arg lists." - - | sz argList val rec activeSel perform | - "Transcript cr; show: aSelector. debug" - perform := aSelector beginsWith: 'perform:'. - sz := argMap size. - 1 to: thisData size do: [:ii | "each example set of args" - argList := (thisData at: ii) copyFrom: 2 to: sz. - perform - ifFalse: [activeSel := aSelector] - ifTrue: [activeSel := argList first. "what will be performed" - ((Approved includes: activeSel) or: [AddAndRemove includes: activeSel]) - ifFalse: [^ false]. "not approved" - aSelector == #perform:withArguments: - ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error" - ifFalse: [^ false]] - ifFalse: [activeSel numArgs = (aSelector numArgs - 1) - ifFalse: [^ false]]]. - 1 to: sz do: [:num | - (Blocks includes: (Array with: activeSel with: num)) ifTrue: [ - (argList at: num) isBlock ifFalse: [^ false]]]. - rec := (AddAndRemove includes: activeSel) - ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false]. - "vulnerable to modification" - (thisData at: ii) first copyTwoLevel] "protect from damage" - ifFalse: [(thisData at: ii) first]. - val := [[rec perform: aSelector withArguments: argList] - on: Deprecation do: [ :ex | ex resume ]] - ifError: [:aString :aReceiver | - "self test3." - "self test2: (thisData at: ii)." - ^ false]. - "self test3." - "self test2: (thisData at: ii)." - ((answers at: ii) closeTo: val) ifFalse: [^ false]. - ]. - ^ true! Item was removed: - ----- Method: MethodFinder>>testRandom (in category 'initialize') ----- - testRandom - "verify that the methods allowed don't crash the system. Pick 3 or 4 from a mixed list of the fundamental types." - - | objects other aa cnt take tuple fName sss random | - objects := #( - (1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four') - (x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3) - ). - - objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}. - {Point class. SmallInteger class. Association class. Array class}. - "{ 4 blocks }." - {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}. - {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}. - {Dictionary new. Dictionary new. Dictionary new. Dictionary new}. - {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. - #($a 3 d) asOrderedCollection. #() asOrderedCollection}. - {3 -> true. 5.6 -> $a. #x -> 2. 'abcd' -> false}. - {9 @ 3 extent: 5 @ 4. 0 @ 0 extent: 45 @ 9. -3 @ -7 extent: 2 @ 2. 4 @ 4 extent: 16 @ 16}. - {Color red. Color blue. Color black. Color gray}}. - - self test2: objects. - "rec+0, rec+1, rec+2, rec+3 need to be tested. " - fName := (FileDirectory default fileNamesMatching: '*.ran') first. - sss := fName splitInteger first. - random := Random seed: sss. - cnt := 0. - - [take := #(3 4) atRandom: random. - tuple := (1 to: take) collect: [:ind | (objects atRandom: random) atRandom: random]. - other := (1 to: take) collect: [:ind | (objects atRandom: random) atRandom: random]. - self load: (aa := Array with: tuple with: 1 with: other with: 7). - ((cnt := cnt + 1) \\ 10 = 0) " | (cnt > Skip)" ifTrue: - [Transcript cr; show: cnt printString; tab; tab; show: aa first printString]. - cnt > (Smalltalk at: #StopHere) ifTrue: [self halt]. "stop just before crash" - cnt > (Smalltalk at: #Skip) - ifTrue: - ["skip this many at start" - self search: true. - self test2: aa first. self test2: (aa at: 3). - "self test2: objects"]] repeat. - ! Item was removed: - ----- Method: MethodFinder>>thisData (in category 'arg maps') ----- - thisData - ^ thisData ! Item was removed: - ----- Method: MethodFinder>>verify (in category 'initialize') ----- - verify - "Test a bunch of examples" - " MethodFinder new verify " - Approved ifNil: [self initialize]. "Sets of allowed selectors" - (MethodFinder new load: #( (0) 0 (30) 0.5 (45) 0.707106 (90) 1) - ) searchForOne asArray = #('data1 degreeSin') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: { { true. [3]. [4]}. 3. { false. [0]. [6]}. 6} - ) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ifFalse: [ - self error: 'should have found it']. - (MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false} - ) searchForOne asArray = #('data1 odd') ifFalse: [self error: 'should have found it']. - "will correct the date type of #true, and complain" - (MethodFinder new load: #((4 2) '2r100' (255 16) '16rFF' (14 8) '8r16') - ) searchForOne asArray = - #('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2') - ifFalse: [self error: 'should have found it']. - (MethodFinder new load: {{Point x: 3 y: 4}. 4. {Point x: 1 y: 5}. 5} - ) searchForOne asArray = #('data1 y') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #(('abcd') $a ('TedK') $T) - ) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne') - ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #(('abcd' 1) $a ('Ted ' 3) $d ) - ) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2') - ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #(((12 4 8)) 24 ((1 3 6)) 10 ) - ) searchForOne asArray= #('data1 sum') ifFalse: [self error: 'should have found it']. - "note extra () needed for an Array object as an argument" - - (MethodFinder new load: #((14 3) 11 (-10 5) -15 (4 -3) 7) - ) searchForOne asArray = #('data1 - data2') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #((4) 4 (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612) - ) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: {#(4 3). true. #(-7 3). false. #(5 1). true. #(5 5). false} - ) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #((5) 0.2 (2) 0.5) - ) searchForOne asArray = #('data1 reciprocal') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #((12 4 8) 2 (1 3 6) 2 (5 2 16) 8) - ) searchForOne asArray = #() " '(data3 / data2) ' want to be able to leave out args" - ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #((0.0) 0.0 (1.5) 0.997495 (0.75) 0.681639) - ) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #((7 5) 2 (4 5) 4 (-9 4) 3) - ) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it']. - - (MethodFinder new load: #((7) 2 (4) 2 ) - ) searchForOne asArray = #('^ 2') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: {#(7). true. #(4.1). true. #(1.5). false} - ) searchForOne asArray = #('data1 >= 4.1') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #((35) 3 (17) 1 (5) 5) - ) searchForOne asArray = #('data1 \\ 8') ifFalse: [self error: 'should have found it']. - (MethodFinder new load: #((36) 7 (50) 10 ) - ) searchForOne asArray = #('data1 quo: 5' 'data1 // 5') ifFalse: [ - self error: 'should have found it']. - (MethodFinder new load: #( ((2 3) 2) 8 ((2 3) 5) 17 ) - ) searchForOne asArray = #('data1 polynomialEval: data2') ifFalse: [ - self error: 'should have found it']. - (MethodFinder new load: #((2) 8 (5) 17 ) - ) searchForOne asArray = #('#(2 3) polynomialEval: data1') ifFalse: [ - self error: 'should have found it']. - ! Item was removed: - CodeHolder subclass: #MethodHolder - instanceVariableNames: 'methodClass methodSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Base'! Item was removed: - ----- Method: MethodHolder>>addModelMenuItemsTo:forMorph:hand: (in category 'menu') ----- - addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph - aCustomMenu addLine. - aCustomMenu add: 'whose script is this?' translated target: self action: #identifyScript - ! Item was removed: - ----- Method: MethodHolder>>changeMethodSelectorTo: (in category 'miscellaneous') ----- - changeMethodSelectorTo: aSelector - "Change my method selector as noted. Reset currentCompiledMethod" - - methodSelector := aSelector. - currentCompiledMethod := methodClass compiledMethodAt: aSelector ifAbsent: [nil]! Item was removed: - ----- Method: MethodHolder>>compiledMethod (in category 'miscellaneous') ----- - compiledMethod - - ^ methodClass compiledMethodAt: methodSelector! Item was removed: - ----- Method: MethodHolder>>contents (in category 'contents') ----- - contents - "Answer the contents, with due respect for my contentsSymbol" - - contents := methodClass sourceCodeAt: methodSelector ifAbsent: ['']. - currentCompiledMethod := methodClass compiledMethodAt: methodSelector ifAbsent: [nil]. - - self showingDecompile ifTrue: [^ self decompiledSourceIntoContents]. - self showingDocumentation ifTrue: [^ self commentContents]. - ^ contents := self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: methodClass! Item was removed: - ----- Method: MethodHolder>>contents:notifying: (in category 'contents') ----- - contents: input notifying: aController - | selector | - (selector := methodClass newParser parseSelector: input asText) ifNil: - [self inform: 'Sorry - invalid format for the - method name and arguments -- cannot accept.'. - ^ false]. - - selector == methodSelector ifFalse: - [self inform: - 'You cannot change the name of - the method here -- it must continue - to be ', methodSelector. - ^ false]. - - selector := methodClass - compile: input asText - classified: self selectedMessageCategoryName - notifying: aController. - selector == nil ifTrue: [^ false]. - contents := input asString copy. - currentCompiledMethod := methodClass compiledMethodAt: methodSelector. - ^ true! Item was removed: - ----- Method: MethodHolder>>identifyScript (in category 'miscellaneous') ----- - identifyScript - | msg aPlayer | - msg := methodClass isUniClass - ifTrue: - [aPlayer := methodClass someInstance. - aPlayer costume - ifNotNil: - ['This holds code for a script - named ', methodSelector, ' belonging - to an object named ', aPlayer externalName] - ifNil: - ['This formerly held code for a script - named ', methodSelector, ' for a Player - who once existed but now is moribund.']] - ifFalse: - ['This holds code for the method - named ', methodSelector, ' - for class ', methodClass name]. - self inform: msg! Item was removed: - ----- Method: MethodHolder>>methodClass:methodSelector: (in category 'miscellaneous') ----- - methodClass: aClass methodSelector: aSelector - methodClass := aClass. - methodSelector := aSelector. - currentCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]! Item was removed: - ----- Method: MethodHolder>>selectedClass (in category 'selection') ----- - selectedClass - ^ methodClass theNonMetaClass! Item was removed: - ----- Method: MethodHolder>>selectedClassOrMetaClass (in category 'selection') ----- - selectedClassOrMetaClass - ^ methodClass! Item was removed: - ----- Method: MethodHolder>>selectedMessageCategoryName (in category 'selection') ----- - selectedMessageCategoryName - ^ methodClass organization categoryOfElement: methodSelector! Item was removed: - ----- Method: MethodHolder>>selectedMessageName (in category 'selection') ----- - selectedMessageName - ^ methodSelector! Item was removed: - ----- Method: MethodHolder>>versions (in category 'miscellaneous') ----- - versions - "Return a VersionsBrowser (containing a list of ChangeRecords) of older versions of this method." - - ^ VersionsBrowser new scanVersionsOf: self compiledMethod - class: self selectedClass - meta: methodClass isMeta - category: self selectedMessageCategoryName - "(classOfMethod whichCategoryIncludesSelector: selectorOfMethod)" - selector: methodSelector! Item was removed: - ----- Method: MethodReference>>browse (in category '*Tools-Browsing') ----- - browse - - ^ ToolSet browse: self actualClass selector: self selector! Item was removed: - ----- Method: Model>>addItem: (in category '*Tools') ----- - addItem: classAndMethod - "Open a browser directly on the given class and method - - Model new addItem: 'Model addItem:' - Model new addItem: 'Model>>addItem:' - " - - self flag: #mref. "classAndMethod is a String" - MessageSet - parse: classAndMethod - toClassAndSelector: [ :class :sel | - class ifNil: [^self]. - sel = #Comment ifTrue: [^ Browser fullOnClassComment: class]. - sel = #Definition ifTrue: [^ Browser newOnClass: class]. - sel = #Hierarchy ifTrue: [^ HierarchyBrowser fullOnClass: class]. - sel = #Help ifTrue: [^HelpBrowser openOn: class]. - Browser newOnClass: class selector: sel - ] - - ! Item was removed: - ----- Method: Model>>anyTextPaneWithSelector: (in category '*Tools') ----- - anyTextPaneWithSelector: aSelector - "Try to find the text pane for aSelector in my dependents or my window. Note that this is a hack only and violates the original idea of the model-view pattern. Usually, the communication should come from the view instead, e.g., via a pluggable selector." - - ^ (self dependentTextPaneWithSelector: aSelector) - ifNil: [self textMorphWithSelector: aSelector]! Item was removed: - ----- Method: Model>>arrowKey:from: (in category '*Tools-keyboard') ----- - arrowKey: aChar from: view - "backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys." - ^false! Item was removed: - ----- Method: Model>>buildMenu:withBuilders:shifted: (in category '*Tools-pluggable menus') ----- - buildMenu: aMenu withBuilders: builders shifted: aBoolean - " We let every builder modify the menu. Skip erroneous builders silently. - The builder should indicate whether to abort by returning nil." - | menu | - menu := aMenu. - builders do: [:builder | | buildBlock | - buildBlock := [menu := self perform: builder method selector withEnoughArguments: {menu . aBoolean}]. - buildBlock - on: Error, Warning, Halt do: [:ex | - menu add: ('<menu builder failed: {1}>' translated format: {ex}) action: buildBlock]]. - ^ menu! Item was removed: - ----- Method: Model>>cleanFileNameForSave: (in category '*Tools-file out') ----- - cleanFileNameForSave: aString - "Removes selected decoration (i.e., leader+trailer) of aString. This decoration usually comes from window titles and the desire to reuse those titles as a file name. - NOTE THAT if only the decoration's leader matches, any existing file extension will be removed. - NOTE THAT if no decoration matches, the '.text' extension is appended if there is none. - SEE #defaultFileNameForSave." - - | cleanFileName | - self flag: #discuss. "mt: Rename 'save' to 'fileOut'?" - cleanFileName := aString. - - #( " 'leader' 'trailer' " - 'Decompressed contents of: ' '.gz' - "Add more here..." - ) groupsDo: [:leader :trailer | - self flag: #discuss. "mt: Maybe extract this feature into String and Text? See #withoutLeading* and #withoutTrailing*." - (cleanFileName beginsWith: leader) ifTrue: [ - cleanFileName := cleanFileName allButFirst: leader size. - (cleanFileName endsWith: trailer) - ifTrue: [cleanFileName := cleanFileName allButLast: trailer size] - ifFalse: [ - | lastIndex | - lastIndex := cleanFileName lastIndexOf: $. ifAbsent: [0]. - lastIndex > 1 ifTrue: [ - cleanFileName := cleanFileName copyFrom: 1 to: lastIndex - 1]] ]]. - - (cleanFileName = aString and: [(cleanFileName includes: $.) not]) - ifTrue: [cleanFileName := cleanFileName, '.text']. - - ^ cleanFileName! Item was removed: - ----- Method: Model>>defaultFileNameForSave (in category '*Tools-file out') ----- - defaultFileNameForSave - "Answer a label that should be used as a file name when saving the receivers textual contents to disk. Note that the answer can also be a relative or absolute file path." - - self flag: #discuss. "mt: Rename 'save' to 'fileOut'?" - ^ self containingWindow - ifNil: ['Untitled'] - ifNotNil: [:window | window label]! Item was removed: - ----- Method: Model>>dependentTextPaneWithSelector: (in category '*Tools-private') ----- - dependentTextPaneWithSelector: selector - - ^ self dependents - detect: [:dependent | dependent isTextView and: - [dependent getTextSelector == selector]] - ifNone: [nil]! Item was removed: - ----- Method: Model>>environment (in category '*Tools') ----- - environment - ^ (self selectedClass ifNil: [self class]) environment! Item was removed: - ----- Method: Model>>menu:for: (in category '*Tools-pluggable menus') ----- - menu: aMenu for: aMenuSymbolOrCollection - - ^ self menu: aMenu for: aMenuSymbolOrCollection shifted: false! Item was removed: - ----- Method: Model>>menu:for:shifted: (in category '*Tools-pluggable menus') ----- - menu: aMenu for: aMenuSymbolOrCollection shifted: aBoolean - - | builders | - builders := self menuBuildersFor: aMenuSymbolOrCollection in: self class shifted: aBoolean. - builders := self sortMenuBuilders: builders. - ^ self buildMenu: aMenu withBuilders: builders shifted: aBoolean - ! Item was removed: - ----- Method: Model>>menuBuildersFor:in:shifted: (in category '*Tools-pluggable menus') ----- - menuBuildersFor: someMenus in: aClass shifted: aBoolean - "Find all builders but reject the ones not matching the shift state " - | pragmas | - pragmas := (self menuPragmasFor: someMenus in: aClass) . - ^ aBoolean - ifTrue: [pragmas reject: [:builder | builder arguments = #(false)]] - ifFalse: [pragmas reject: [:builder | builder arguments = #(true)]]. - ! Item was removed: - ----- Method: Model>>menuPragmasFor:in: (in category '*Tools-pluggable menus') ----- - menuPragmasFor: aMenuSymbolOrCollection in: aClass - - ^ aMenuSymbolOrCollection isSymbol - ifFalse: [aMenuSymbolOrCollection gather: [:aMenuSymbol | - Pragma allNamed: aMenuSymbol from: aClass to: Object]] - ifTrue: [Pragma allNamed: aMenuSymbolOrCollection from: aClass to: Object]! Item was removed: - ----- Method: Model>>methodMenuPriority: (in category '*Tools-pluggable menus') ----- - methodMenuPriority: aMethod - "The pirority of a menu method indicated by a <menuPriority: ...> pragma. - Defaults to 500" - ^ (aMethod pragmas detect: [:p | p keyword == #menuPriority: ] ifNone: [^ 500]) - argumentAt: 1 - ! Item was removed: - ----- Method: Model>>saveContents: (in category '*Tools-file out') ----- - saveContents: stringContents - "Interactive. See #saveContents:accessMode:." - - ^ self - saveContents: stringContents - accessMode: #create! Item was removed: - ----- Method: Model>>saveContents:accessMode: (in category '*Tools-file out') ----- - saveContents: stringContents accessMode: accessMode - "Interactive callback from TextEditor. Ask the user for a file name/path, suggesting a (cleaned-up) default name to accept. Answers whether the save request was successful." - - ^ (Project uiManager - saveFilenameRequest: 'Save text contents in file...' translated - initialAnswer: self suggestedFileNameForSave) - ifNil: [false] ifNotNil: [:answer | answer ifEmpty: [false] - ifNotEmpty: [:fileName | - self - saveContents: stringContents - onFileNamed: fileName - accessMode: accessMode]].! Item was removed: - ----- Method: Model>>saveContents:onFileNamed:accessMode: (in category '*Tools-file out') ----- - saveContents: stringContents onFileNamed: fileName accessMode: accessMode - - ^ self - saveContents: stringContents - onFileNamed: fileName - accessMode: accessMode - workBlock: [:fileStream | fileStream nextPutAll: stringContents]! Item was removed: - ----- Method: Model>>saveContents:onFileNamed:accessMode:workBlock: (in category '*Tools-file out') ----- - saveContents: stringContents onFileNamed: fileName accessMode: accessMode workBlock: workBlock - "Save stringContents on fileName. Answers whether the save request was successful. On success, fileName will exist, including any new directories in the relative/absolute path. - - accessMode - #create ... Prompt the user if file exists. - #update ... Replace all contents if file exists. - #append ... Append new contents if file exists." - - (FileDirectory default on: fileName) containingDirectory assureExistence. - accessMode caseOf: { - [#create] -> [FileStream newFileNamed: fileName do: workBlock]. - [#update] -> [FileStream forceNewFileNamed: fileName do: workBlock]. - [#append] -> [FileStream fileNamed: fileName do: [:s | s setToEnd. workBlock value: s]] } - otherwise: [ - self error: ('Unknown file access mode: {1}' translated format: {accessMode printString}). - ^ false]. - - Transcript showln: ('{1} contents saved (via {2}) to: {3}' format: { self class. accessMode printString. fileName }). - ^ true! Item was removed: - ----- Method: Model>>selectedClass (in category '*Tools') ----- - selectedClass - "All owners of TextViews are asked this during a doIt" - ^ nil! Item was removed: - ----- Method: Model>>sortMenuBuilders: (in category '*Tools-pluggable menus') ----- - sortMenuBuilders: builders - " Sort them by - 1. Priority (default 500) - 2. selector name - " - ^ builders sorted: [:a :b | - | ma mb pa pb | - ma := a method. - mb := b method. - pa := self methodMenuPriority: ma. - pb := self methodMenuPriority: mb. - pa < pb or: [pa = pb and: [ma selector <= mb selector]]] - ! Item was removed: - ----- Method: Model>>spawn: (in category '*Tools') ----- - spawn: contentsString - - UIManager default edit: contentsString label: nil! Item was removed: - ----- Method: Model>>suggestedFileNameForSave (in category '*Tools-file out') ----- - suggestedFileNameForSave - - ^ self cleanFileNameForSave: self defaultFileNameForSave! Item was removed: - ----- Method: Model>>textMorphWithSelector: (in category '*Tools-private') ----- - textMorphWithSelector: aSelector - "If, among my window's paneMorphs, there is a text pane defined with aSelector as its retriever, answer it, else answer nil. Morphic only." - - | aWindow | - Smalltalk isMorphic ifFalse: [^ nil]. - ^ (aWindow := self containingWindow) ifNotNil: - [aWindow paneMorphSatisfying: - [:aMorph | (aMorph isKindOf: PluggableTextMorph) and: - [aMorph getTextSelector == aSelector]]]! Item was removed: - ----- Method: Model>>trash (in category '*Tools-menus') ----- - trash - "What should be displayed if a trash pane is restored to initial state" - - ^ ''! Item was removed: - ----- Method: Model>>trash: (in category '*Tools-menus') ----- - trash: ignored - "Whatever the user submits to the trash, it need not be saved." - - ^ true! Item was removed: - ----- Method: Morph class>>toolIcon (in category '*Tools-icons') ----- - toolIcon - - ^ #morph! Item was removed: - ----- Method: Number>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Number'! Item was removed: - ----- Method: Object>>basicInspect (in category '*Tools-Inspector') ----- - basicInspect - "Create and schedule an Inspector in which the user can examine the - receiver's variables. This method should not be overriden." - ToolSet basicInspect: self! Item was removed: - ----- Method: Object>>browse (in category '*Tools-Browsing') ----- - browse - ToolSet browseClass: self class! Item was removed: - ----- Method: Object>>browseAllCallsOn: (in category '*Tools-MessageSets') ----- - browseAllCallsOn: selectorSymbol - "A tool's widget/view (i.e., 'requestor') requested to browse the calls on selectorSymbol. By default, let #systemNavigation handle it." - - self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream." - self systemNavigation browseAllCallsOn: selectorSymbol! Item was removed: - ----- Method: Object>>browseAllCallsOn:requestor: (in category '*Tools-MessageSets') ----- - browseAllCallsOn: selectorSymbol requestor: anObject - "A tool's widget/view (i.e., 'requestor') requested to browse the calls on selectorSymbol. By default, let #systemNavigation handle it." - - self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream." - self browseAllCallsOn: selectorSymbol! Item was removed: - ----- Method: Object>>browseAllImplementorsOf: (in category '*Tools-MessageSets') ----- - browseAllImplementorsOf: selectorSymbol - "A tool's widget/view (i.e., 'requestor') requested to browse the implementors of selectorSymbol. By default, let #systemNavigation handle it." - - self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream." - self systemNavigation browseAllImplementorsOf: selectorSymbol.! Item was removed: - ----- Method: Object>>browseAllImplementorsOf:requestor: (in category '*Tools-MessageSets') ----- - browseAllImplementorsOf: selectorSymbol requestor: anObject - "A tool's widget/view (i.e., 'requestor') requested to browse the implementors of selectorSymbol. By default, let #systemNavigation handle it." - - self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream." - self browseAllImplementorsOf: selectorSymbol.! Item was removed: - ----- Method: Object>>browseHierarchy (in category '*tools-browser') ----- - browseHierarchy - self systemNavigation browseHierarchy: self class! Item was removed: - ----- Method: Object>>canHaveUnacceptedEdits (in category '*Tools-multi-window support') ----- - canHaveUnacceptedEdits - "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)" - - ^false! Item was removed: - ----- Method: Object>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - "Answer a name that describes the type or class of this object for creating - an argument name for an argument of similar type in a stub method." - - ^ self class name! Item was removed: - ----- Method: Object>>chasePointers (in category '*Tools-Debugger') ----- - chasePointers - PointerFinder on: self! Item was removed: - ----- Method: Object>>environment (in category '*Tools') ----- - environment - "This is a fallback for models that do not inherit from Model or something else that provides - a useful Environment answer. You should consider copying this method to (base) classes of - objects from which you expect exactly the behavior below. - Absolutely feel free to override this method for objects that have or operate on a dedicated - environment, such as references to classes, code loaders, or tools." - ^ self class environment! Item was removed: - ----- Method: Object>>explore (in category '*Tools-Explorer') ----- - explore - ToolSet explore: self! Item was removed: - ----- Method: Object>>explorePointers (in category '*Tools-Debugger') ----- - explorePointers - PointerExplorer openOn: self! Item was removed: - ----- Method: Object>>exploreWithLabel: (in category '*Tools-Explorer') ----- - exploreWithLabel: label - ToolSet explore: self label: label! Item was removed: - ----- Method: Object>>inspect (in category '*Tools-Inspector') ----- - inspect - "Create and schedule an Inspector in which the user can examine the receiver's variables." - ToolSet inspect: self! Item was removed: - ----- Method: Object>>inspectWithLabel: (in category '*Tools-Inspector') ----- - inspectWithLabel: aLabel - "Create and schedule an Inspector in which the user can examine the receiver's variables." - ToolSet inspect: self label: aLabel! Item was removed: - ----- Method: Object>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^ Inspector! Item was removed: - ----- Method: Object>>shouldFollowOutboundPointers (in category '*Tools-Debugger') ----- - shouldFollowOutboundPointers - "Allow other subclasses of ProtoObject to hook this method." - (self class isPointers or: [ self isCompiledCode ]) ifFalse: [ ^ false ]. - ^ (self class isWeak not or: [ self class instSize > 0 ]) and: [ self isLiteral not ]! Item was removed: - AbstractHierarchicalList subclass: #ObjectExplorer - instanceVariableNames: 'root currentParent inspector monitorList expression' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Explorer'! - - !ObjectExplorer commentStamp: '<historical>' prior: 0! - ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like: - - World explore - - and enjoy.! Item was removed: - ----- Method: ObjectExplorer class>>about (in category 'defaults') ----- - about - - StringHolder new textContents: self comment; openLabel: 'about ',self asString! Item was removed: - ----- Method: ObjectExplorer class>>explore: (in category 'instance creation') ----- - explore: anObject - - ^ self new explore: anObject! Item was removed: - ----- Method: ObjectExplorer class>>nodeClass (in category 'defaults') ----- - nodeClass - - ^ ObjectExplorerWrapper! Item was removed: - ----- Method: ObjectExplorer class>>openOn: (in category 'instance creation') ----- - openOn: anObject - - ^ ToolBuilder open: (self explore: anObject)! Item was removed: - ----- Method: ObjectExplorer class>>openOn:withLabel: (in category 'instance creation') ----- - openOn: anObject withLabel: label - "ObjectExplorer openOn: Smalltalk withLabel: 'Smalltalk'" - - ^ ToolBuilder open: (self explore: anObject) label: label! Item was removed: - ----- Method: ObjectExplorer>>aboutToStyle: (in category 'styling') ----- - aboutToStyle: aStyler - - aStyler - classOrMetaClass: self object class; - environment: self environment; - parseAMethod: false. - ^true! Item was removed: - ----- Method: ObjectExplorer>>browseClassHierarchy (in category 'menus - actions') ----- - browseClassHierarchy - "Create and schedule a class list browser on the receiver's hierarchy." - - self systemNavigation - spawnHierarchyForClass: self selectedClass - selector: nil.! Item was removed: - ----- Method: ObjectExplorer>>browseClassRefs (in category 'menus - actions') ----- - browseClassRefs - - self selectedClass ifNotNil: [:cls | - cls isTrait ifFalse: [self systemNavigation browseAllCallsOnClass: cls]]! Item was removed: - ----- Method: ObjectExplorer>>browseFull (in category 'menus - actions') ----- - browseFull - - ^ self selectedClass ifNotNil: [:cls | ToolSet browseClass: cls]! Item was removed: - ----- Method: ObjectExplorer>>browseVariableAssignments (in category 'menus - actions') ----- - browseVariableAssignments - - (self selectedClass notNil and: [self selectedClass isTrait not]) - ifTrue: [self systemNavigation browseVariableAssignments: self selectedClass].! Item was removed: - ----- Method: ObjectExplorer>>browseVariableReferences (in category 'menus - actions') ----- - browseVariableReferences - - (self selectedClass notNil and: [self selectedClass isTrait not]) - ifTrue: [self systemNavigation browseVariableReferences: self selectedClass].! Item was removed: - ----- Method: ObjectExplorer>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - - | windowSpec treeSpec textSpec buttonSpec buttonOffset tool | - windowSpec := builder pluggableWindowSpec new. - windowSpec - model: self; - children: OrderedCollection new; - label: #label; - extent: self initialExtent. - - treeSpec := builder pluggableTreeSpec new. - treeSpec - model: self; - nodeClass: self class nodeClass; - roots: #getList; - keyPress: #explorerKey:from:event:; - getSelected: #currentSelection; - setSelected: #currentSelection:; - setSelectedParent: #currentParent:; - menu: #genericMenu:; - dragItem: #getDragItem:; - autoDeselect: false; - columns: (ObjectExplorerWrapper showContentsInColumns - ifTrue: [{ - [:listMorph | (listMorph filteredItems collect: [:item | - item preferredWidthOfColumn: 1]) max]. - nil "take all the space"}]); - frame: (0 at 0 corner: 1 at 0.71). - windowSpec children add: treeSpec. - - buttonOffset := (Preferences standardButtonFont widthOfString: 'inspect') * 3/2. - - textSpec := builder pluggableCodePaneSpec new. - textSpec - model: self; - getText: #expression; - editText: #expression:; - menu: #codePaneMenu:shifted:; - help: 'Evaluate expressions for the current tree selection...' translated; - frame: (LayoutFrame fractions: (0 at 0.71 corner: 1 at 1) offsets: (0 at 0 corner: buttonOffset negated at 0)). - windowSpec children add: textSpec. - - buttonSpec := builder pluggableButtonSpec new - model: self; - label: 'inspect'; - action: #inspectObject; - help: 'Switch to an inspector tool'; - frame: (LayoutFrame fractions: (1 at 0.71 corner: 1 at 1) offsets: (buttonOffset negated at 0 corner: 0 @ 0)). - windowSpec children add: buttonSpec. - - tool := builder build: windowSpec. - self changed: #expandRootsRequested. - ^ tool! Item was removed: - ----- Method: ObjectExplorer>>chasePointersForSelection (in category 'menus - actions') ----- - chasePointersForSelection - - PointerFinder on: self object except: self possibleReferencesToSelection! Item was removed: - ----- Method: ObjectExplorer>>codePaneMenu:shifted: (in category 'menus') ----- - codePaneMenu: aMenu shifted: shifted - "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items" - ^ StringHolder codePaneMenu: aMenu shifted: shifted - ! Item was removed: - ----- Method: ObjectExplorer>>copyName (in category 'menus - actions') ----- - copyName - "Copy the name of the current variable, so the user can paste it into the window below and work with it." - - Clipboard clipboardText: self currentSelection key. ! Item was removed: - ----- Method: ObjectExplorer>>copyValue (in category 'menus - actions') ----- - copyValue - "Copy a description of the value of the current variable, so the user can paste it into the window below and work with it." - - Clipboard clipboardText: self currentSelection value asStringOrText. ! Item was removed: - ----- Method: ObjectExplorer>>currentParent (in category 'accessing') ----- - currentParent - ^ currentParent! Item was removed: - ----- Method: ObjectExplorer>>currentParent: (in category 'accessing') ----- - currentParent: anObject - currentParent := anObject.! Item was removed: - ----- Method: ObjectExplorer>>currentSelection (in category 'accessing') ----- - currentSelection - - ^ currentSelection! Item was removed: - ----- Method: ObjectExplorer>>currentSelection: (in category 'accessing') ----- - currentSelection: anObject - - self currentSelection == anObject ifTrue: [ - self changed: #objectChanged with: anObject. - ^ self]. - - currentSelection := anObject. - - self changed: #currentSelection. - self changed: #style.! Item was removed: - ----- Method: ObjectExplorer>>defsOfSelection (in category 'menus - actions') ----- - defsOfSelection - "Open a browser on all defining references to the selected instance variable, if that's what currently selected. " - - self selectedParentClass ifNil: [^ self changed: #flash]. - self selectedParentClass isVariable ifTrue: [^ self changed: #flash]. - self selectedInstVarName ifNil: [^ self changed: #flash]. - - self systemNavigation browseAllStoresInto: self selectedInstVarName from: self selectedParentClass.! Item was removed: - ----- Method: ObjectExplorer>>doItContext (in category 'accessing') ----- - doItContext - "Answer the context in which a text selection can be evaluated." - - ^nil! Item was removed: - ----- Method: ObjectExplorer>>doItReceiver (in category 'accessing') ----- - doItReceiver - "Answer the object that should be informed of the result of evaluating a - text selection." - - ^ self object! Item was removed: - ----- Method: ObjectExplorer>>explore: (in category 'user interface') ----- - explore: anObject - - self rootObject: anObject.! Item was removed: - ----- Method: ObjectExplorer>>explorePointersForSelection (in category 'menus - actions') ----- - explorePointersForSelection - - self flag: #tooMany. "mt: Note that we might want to ignore references caused by this tool." - self object explorePointers.! Item was removed: - ----- Method: ObjectExplorer>>exploreSelection (in category 'menus - actions') ----- - exploreSelection - - self object explore.! Item was removed: - ----- Method: ObjectExplorer>>explorerKey:from:event: (in category 'menus') ----- - explorerKey: aChar from: view event: event - - event anyModifierKeyPressed ifFalse: [^ false]. - - self object ifNotNil: [ - aChar == $i ifTrue: [self inspectSelection. ^ true]. - aChar == $I ifTrue: [self exploreSelection. ^ true]. - - aChar == $b ifTrue: [self browseFull. ^ true]. - aChar == $h ifTrue: [self browseClassHierarchy. ^ true]. - aChar == $c ifTrue: [self copyName. ^ true]. - aChar == $p ifTrue: [self browseFullProtocol. ^ true]. - aChar == $N ifTrue: [self browseClassRefs. ^ true]. - aChar == $v ifTrue: [self viewerForValue. ^ true]]. - - ^ false! Item was removed: - ----- Method: ObjectExplorer>>expression (in category 'accessing') ----- - expression - - ^ expression! Item was removed: - ----- Method: ObjectExplorer>>expression: (in category 'accessing') ----- - expression: aString - - expression := aString.! Item was removed: - ----- Method: ObjectExplorer>>findDeepSubmorphsIn:that: (in category 'accessing - view') ----- - findDeepSubmorphsIn: aMorph that: aBlock - - | selectedSubmorphs | - selectedSubmorphs := aMorph submorphs select: aBlock. - ^ selectedSubmorphs, (aMorph submorphs collect: [:each | - self findDeepSubmorphsIn: each that: aBlock]) flatten! Item was removed: - ----- Method: ObjectExplorer>>genericMenu: (in category 'menus') ----- - genericMenu: aMenu - - ^ self menu: aMenu for: #(treeListMenu treeListMenuShifted:)! Item was removed: - ----- Method: ObjectExplorer>>getDragItem: (in category 'user interface') ----- - getDragItem: binding - - ^ binding value! Item was removed: - ----- Method: ObjectExplorer>>getList (in category 'accessing') ----- - getList - "This explorer shows bindings in a tree structure. Create the root binding here." - - ^ {self root}! Item was removed: - ----- Method: ObjectExplorer>>initialExtent (in category 'user interface') ----- - initialExtent - - ^350 at 250! Item was removed: - ----- Method: ObjectExplorer>>inspectBasic (in category 'menus - actions') ----- - inspectBasic - "Bring up a non-special inspector" - - self object basicInspect.! Item was removed: - ----- Method: ObjectExplorer>>inspectObject (in category 'toolbuilder') ----- - inspectObject - "Switch to an inspector tool." - - | window currentBounds | - currentBounds := ToolBuilder findDefault getBoundsForWindow: self containingWindow. - - "Close first because MVC fiddles around with processes." - self changed: #close. - - window := ToolSet inspect: self rootObject. - - "---- In MVC, the lines after this will not be executed ---" - - window model setExpression: self expression. - ToolBuilder findDefault setBoundsForWindow: window to: currentBounds.! Item was removed: - ----- Method: ObjectExplorer>>inspectSelection (in category 'menus - actions') ----- - inspectSelection - - self object inspect.! Item was removed: - ----- Method: ObjectExplorer>>inspector (in category 'accessing - other') ----- - inspector - - ^ inspector ifNil: [inspector := Inspector new]! Item was removed: - ----- Method: ObjectExplorer>>label (in category 'accessing') ----- - label - - ^ [self rootObject printStringLimitedTo: 40] ifError: ['a ' , self rootObject class]! Item was removed: - ----- Method: ObjectExplorer>>mainTreeListMenu: (in category 'menus') ----- - mainTreeListMenu: aMenu - <treeListMenu> - - aMenu addStayUpItemSpecial. - - aMenu addList: #( - ('inspect (i)' inspectSelection) - ('explore (I)' exploreSelection) - - - ('method refs to this inst var' referencesToSelection) - ('methods storing into this inst var' defsOfSelection) - ('objects pointing to this value' objectReferencesToSelection) - ('chase pointers' chasePointersForSelection) - ('explore pointers' explorePointersForSelection) - - - ('browse full (b)' browseFull) - ('browse hierarchy (h)' browseClassHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('references... (r)' browseVariableReferences) - ('assignments... (a)' browseVariableAssignments) - ('class refs (N)' browseClassRefs) - - - ('copy name (c)' copyName) - ('copy value' copyValue) - ('basic inspect' inspectBasic)). - - Smalltalk isMorphic ifTrue: [ - aMenu addList: #( - - - ('viewer for this value (v)' viewerForValue))]. - - aMenu addList: #( - - - ('monitor changes' monitorSelection)). - - monitorList isEmptyOrNil ifFalse: [ - aMenu addList: #( - ('stop monitoring all' stopMonitoring))]. - - ^ aMenu! Item was removed: - ----- Method: ObjectExplorer>>monitor: (in category 'monitoring') ----- - monitor: aBinding - "Start stepping and watching the given binding for changes." - - aBinding ifNil: [ ^self ]. - self world ifNil: [ ^self ]. - self monitorList add: aBinding. - - self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 2000.! Item was removed: - ----- Method: ObjectExplorer>>monitorList (in category 'monitoring') ----- - monitorList - ^monitorList ifNil: [ monitorList := WeakOrderedCollection new ].! Item was removed: - ----- Method: ObjectExplorer>>monitorSelection (in category 'menus - actions') ----- - monitorSelection - - self monitor: self currentSelection.! Item was removed: - ----- Method: ObjectExplorer>>object (in category 'accessing - objects') ----- - object - - ^ self currentSelection value! Item was removed: - ----- Method: ObjectExplorer>>objectReferencesToSelection (in category 'menus - actions') ----- - objectReferencesToSelection - "Open a list inspector on all the objects that point to the value of the selected instance variable, if any. " - - self object ifNil: [^ self changed: #flash]. - - self systemNavigation - browseAllObjectReferencesTo: self object - except: {self currentSelection. self currentParent. self parentObject} - ifNone: [:obj | self changed: #flash].! Item was removed: - ----- Method: ObjectExplorer>>okToClose (in category 'user interface') ----- - okToClose - "Give the object-under-exploration a chance to react. Maybe this explorer is an important reference to the object and the user needs to be informed about this fact." - - ^ super okToClose - and: [(self rootObject respondsTo: #explorerOkToClose) - ==> [(self rootObject perform: #explorerOkToClose) == true]]! Item was removed: - ----- Method: ObjectExplorer>>okToRevertChanges: (in category 'user edits') ----- - okToRevertChanges: aspect - "Clear caches since we use #textEdited: callback from view." - - aspect = #expression: ifTrue: [expression := '']. - ^ true! Item was removed: - ----- Method: ObjectExplorer>>parentObject (in category 'accessing - objects') ----- - parentObject - - ^ self currentParent value! Item was removed: - ----- Method: ObjectExplorer>>possibleReferencesToSelection (in category 'accessing - view') ----- - possibleReferencesToSelection - - ^ {self}, self visibleObjectExplorerWrappers! Item was removed: - ----- Method: ObjectExplorer>>referencesToSelection (in category 'menus - actions') ----- - referencesToSelection - "Open a browser on all references to the selected instance variable, if that's what currently selected." - - self selectedParentClass ifNil: [^ self changed: #flash]. - self selectedParentClass isVariable ifTrue: [^ self changed: #flash]. - self selectedInstVarName ifNil: [^ self changed: #flash]. - - self systemNavigation browseAllAccessesTo: self selectedInstVarName from: self selectedParentClass.! Item was removed: - ----- Method: ObjectExplorer>>release (in category 'monitoring') ----- - release - self world ifNotNil: [ :world | world stopStepping: self selector: #step ]. - super release.! Item was removed: - ----- Method: ObjectExplorer>>representsSameBrowseeAs: (in category 'user interface') ----- - representsSameBrowseeAs: anotherObjectExplorer - ^ self rootObject == anotherObjectExplorer rootObject! Item was removed: - ----- Method: ObjectExplorer>>root (in category 'accessing') ----- - root - - ^ root ifNil: [root := 'root' -> nil]! Item was removed: - ----- Method: ObjectExplorer>>rootObject (in category 'accessing - objects') ----- - rootObject - - ^ self root value! Item was removed: - ----- Method: ObjectExplorer>>rootObject: (in category 'accessing - objects') ----- - rootObject: anObject - - self root value: anObject. - - self changed: #label. - self changed: #getList. - self changed: #expandRootsRequested. - - self currentSelection: self getList first.! Item was removed: - ----- Method: ObjectExplorer>>selectedClass (in category 'accessing - other') ----- - selectedClass - "Answer the class of the receiver's current selection" - - ^self doItReceiver class - ! Item was removed: - ----- Method: ObjectExplorer>>selectedInstVarName (in category 'accessing - other') ----- - selectedInstVarName - - self parentObject ifNil: [^ nil]. - (self parentObject class allInstVarNames includes: self currentSelection key) - ifTrue: [^ self currentSelection key asSymbol]. - ^ nil! Item was removed: - ----- Method: ObjectExplorer>>selectedParentClass (in category 'accessing - other') ----- - selectedParentClass - - ^ self parentObject ifNotNil: [:o | o class]! Item was removed: - ----- Method: ObjectExplorer>>setExpression: (in category 'accessing - other') ----- - setExpression: aString - - self expression: aString. - self changed: #expression.! Item was removed: - ----- Method: ObjectExplorer>>shouldGetStepsFrom: (in category 'monitoring') ----- - shouldGetStepsFrom: aWorld - ^self monitorList notEmpty! Item was removed: - ----- Method: ObjectExplorer>>step (in category 'monitoring') ----- - step - "Let all views know that some of my objects need to be updated." - - self monitorList do: [ :object | - object ifNotNil: [self changed: #objectChanged with: object]]. - self monitorList ifEmpty: [ - self world stopStepping: self selector: #step ].! Item was removed: - ----- Method: ObjectExplorer>>stopMonitoring (in category 'monitoring') ----- - stopMonitoring - monitorList := nil. - self world ifNotNil: [ :world | world stopStepping: self selector: #step].! Item was removed: - ----- Method: ObjectExplorer>>veryDeepInner: (in category 'copying') ----- - veryDeepInner: aDeepCopier - super veryDeepInner: aDeepCopier. - inspector := inspector veryDeepCopyWith: aDeepCopier. - monitorList := monitorList veryDeepCopyWith: aDeepCopier. - expression := expression veryDeepCopyWith: aDeepCopier! Item was removed: - ----- Method: ObjectExplorer>>viewerForValue (in category 'menus - actions') ----- - viewerForValue - - self object beViewed.! Item was removed: - ----- Method: ObjectExplorer>>views (in category 'accessing - view') ----- - views - - ^ self findDeepSubmorphsIn: self world that: [:morph | - morph modelOrNil = self]! Item was removed: - ----- Method: ObjectExplorer>>visibleListItems (in category 'accessing - view') ----- - visibleListItems - - | lists | - lists := self views select: [:morph | - (morph isKindOf: PluggableTreeMorph)]. - ^ (lists collect: [:each| - each items]) flatten! Item was removed: - ----- Method: ObjectExplorer>>visibleObjectExplorerWrappers (in category 'accessing - view') ----- - visibleObjectExplorerWrappers - - | listItems | - listItems := self visibleListItems. - ^ listItems collect: [:each | each complexContents]! Item was removed: - ----- Method: ObjectExplorer>>world (in category 'monitoring') ----- - world - | project | - ^(project := Project current) isMorphic ifTrue: [project world]! Item was removed: - ----- Method: PackageInfo>>browse (in category '*Tools-Browsing') ----- - browse - - ^ ToolSet browsePackage: self! Item was removed: - Browser subclass: #PackagePaneBrowser - instanceVariableNames: 'package packageListIndex packageList' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !PackagePaneBrowser commentStamp: '<historical>' prior: 0! - A package browser represents a hierarchical query path through an organization of class and method information. It parses class categories into a two-level hierarchy on the first '-' character, giving "packages" (e.g., Magnitude, Collections, Graphics, etc.), and "categories" (e.g., Magnitude-General and Magnitude-Number). - - Instance Variables: - package <Symbol> the "category header," e.g., #Magnitudes or #Collections - packageListIndex <Integer> The index in the package list - packageList <OrderedCollection of String> the list of package names - ! Item was removed: - ----- Method: PackagePaneBrowser class>>fullOnPackage: (in category 'instance creation') ----- - fullOnPackage: aPackage - - ^ self new - selectPackageNamed: aPackage name; - buildAndOpenFullBrowser! Item was removed: - ----- Method: PackagePaneBrowser class>>registerInAppRegistry (in category 'class initialization') ----- - registerInAppRegistry - "Register the receiver in the SystemBrowser AppRegistry" - SystemBrowser register: self.! Item was removed: - ----- Method: PackagePaneBrowser>>buildDefaultBrowserWith: (in category 'toolbuilder') ----- - buildDefaultBrowserWith: builder - "assemble the spec for a full 5-pane browser - package, category, class, protocol & message lists, build it and return the built but not opened morph. - the build-but-don't-open phase is factored out to support the prototypicalToolWindow facility" - - "PackagePaneBrowser fullOnClass: Browser." - - | max windowSpec | - max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5]. - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 0.15 at max) -> [self buildPackageListWith: builder]. - (0.15 at 0 corner: 0.35 at max) -> [self buildSystemCategoryListWith: builder]. - (self classListFrame: max fromLeft: 0.35 width: 0.25) -> [self buildClassListWith: builder]. - (self switchesFrame: max fromLeft: 0.35 width: 0.25) -> [self buildSwitchesWith: builder]. - (0.6 at 0 corner: 0.75 at max) -> [self buildMessageCategoryListWith: builder]. - (0.75 at 0 corner: 1 at max) -> [self buildMessageListWith: builder]. - (0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - self setMultiWindowFor:windowSpec. - windowSpec defaultFocus: #packageList. - - ^builder build: windowSpec! Item was removed: - ----- Method: PackagePaneBrowser>>buildPackageListWith: (in category 'toolbuilder') ----- - buildPackageListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - name: #packageList; - list: #packageList; - getIndex: #packageListIndex; - setIndex: #packageListIndex:; - menu: #packageMenu:; - keyPress: #packageListKey:from:. - ^listSpec - ! Item was removed: - ----- Method: PackagePaneBrowser>>categoryExistsForPackage (in category 'package list') ----- - categoryExistsForPackage - ^ self hasPackageSelected - and: [(systemOrganizer categories indexOf: self package asSymbol) ~= 0] - ! Item was removed: - ----- Method: PackagePaneBrowser>>changeCategoryForClass:srcSystemCategory:atListMorph:internal:copy: (in category 'dragNDrop') ----- - changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag - "only move semantic" - | newClassCategory success | - self flag: #stringSymbolProblem. - success := copyFlag not ifFalse: [^ false]. - newClassCategory := self dstCategoryDstListMorph: dstListMorph internal: internal. - (success := newClassCategory notNil & (newClassCategory ~= class category)) - ifTrue: - [class category: newClassCategory. - self changed: #classList. - internal ifFalse: [self selectClass: class]]. - ^ success! Item was removed: - ----- Method: PackagePaneBrowser>>classList (in category 'class list') ----- - classList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - - ^ self hasSystemCategorySelected - ifFalse: [self packageClasses] - ifTrue: [systemOrganizer listAtCategoryNamed: self selectedSystemCategory]! Item was removed: - ----- Method: PackagePaneBrowser>>defaultBrowserTitle (in category 'initialize-release') ----- - defaultBrowserTitle - ^ 'Package Browser'! Item was removed: - ----- Method: PackagePaneBrowser>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.9 g: 0.9 b: 0.63)! Item was removed: - ----- Method: PackagePaneBrowser>>dstCategoryDstListMorph:internal: (in category 'dragNDrop util') ----- - dstCategoryDstListMorph: dstListMorph internal: internal - | dropItem | - ^ internal & (dstListMorph getListSelector == #systemCategoryList) - ifTrue: [(dropItem := dstListMorph potentialDropItem) ifNotNil: [(self package , '-' , dropItem) asSymbol]] - ifFalse: [self selectedSystemCategory]! Item was removed: - ----- Method: PackagePaneBrowser>>hasPackageSelected (in category 'package list') ----- - hasPackageSelected - - ^ packageListIndex ~= 0! Item was removed: - ----- Method: PackagePaneBrowser>>hasSystemCategorySelected (in category 'system category list') ----- - hasSystemCategorySelected - ^ super selectedSystemCategory notNil.! Item was removed: - ----- Method: PackagePaneBrowser>>isPackage (in category 'multi-window support') ----- - isPackage - ^true! Item was removed: - ----- Method: PackagePaneBrowser>>labelString (in category 'initialize-release') ----- - labelString - ^self package - ifNil: [super labelString] - ifNotNil: - [:pkg| | label | - label := self defaultBrowserTitle, ': ', pkg, (self selectedClass - ifNil: [''] - ifNotNil: [' ', self selectedClass printString]). - (self multiWindowState notNil - and: [self multiWindowState models size > 1]) ifTrue: - [label := (self multiWindowState models indexOf: self) printString, '. ', label]. - label]! Item was removed: - ----- Method: PackagePaneBrowser>>mainPackageMenu: (in category 'package list') ----- - mainPackageMenu: aMenu - "Answer a Menu of operations on class packages to be - displayed when the operate menu button is pressed." - <packageListMenu> - ^aMenu addList: #( - ('find class... (f)' findClass) - ('back... (b)' recent) - - - ('browse extensions' browsePackageExtensions) - ('browse dependencies' browsePackageDependencies) - ('browse inverted dependencies' browsePackageDependenciesInverted) - - - ('reorganize' editSystemCategories) - ('alphabetize' alphabetizeSystemCategories) - - - ('update' updatePackages)); - yourself.! Item was removed: - ----- Method: PackagePaneBrowser>>multiWindowName (in category 'multi-window support') ----- - multiWindowName - "Answer the string to display for the receiver in a multi-window." - ^String streamContents: - [:s| | str | - self package - ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle] - ifNotNil: - [:pkg| - self selectedClass - ifNil: [self selectedSystemCategory - ifNil: [s nextPutAll: pkg] - ifNotNil: [:cat| s nextPutAll: cat]] - ifNotNil: - [:class| - s nextPutAll: pkg; space; print: class. - self metaClassIndicated ifTrue: - [s nextPutAll: ' class']]]. - (str := self selectedMessageName) notNil - ifTrue: [s nextPutAll: '>>'; nextPutAll: str] - ifFalse: - [(str := self selectedMessageCategoryName) notNil - ifTrue: [s space; nextPut: ${; nextPutAll: str; nextPut: $}]]]! Item was removed: - ----- Method: PackagePaneBrowser>>multiWindowNameForState: (in category 'multi-window support') ----- - multiWindowNameForState: savedStateMessage - "Answer the string to display for the receiver in a multi-window." - | getarg | - getarg := [:keyword| savedStateMessage arguments at: (savedStateMessage selector keywords indexOf: keyword)]. - ^String streamContents: - [:s| - (getarg value: 'restoreToPackage:') - ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle] - ifNotNil: - [:pkg| - s nextPutAll: pkg. - (getarg value: 'className:') - ifNil: [(getarg value: 'category:') ifNotNil: - [:categoryName| s nextPut: $-; nextPutAll: categoryName]] - ifNotNil: - [:className| - s space; nextPutAll: className. - (getarg value: 'meta:') ifTrue: - [s nextPutAll: ' class']. - self isHierarchy ifTrue: - [s space; nextPutAll: ' Hierarchy']. - (getarg value: 'selector:') - ifNil: [(getarg value: 'protocol:') ifNotNil: - [:protocol| s space; nextPut: ${; nextPutAll: protocol; nextPut: $}]] - ifNotNil: [:selector| s nextPutAll: '>>'; nextPutAll: selector]]]]! Item was removed: - ----- Method: PackagePaneBrowser>>package (in category 'package list') ----- - package - "Answer the receiver's 'package'." - - ^ self selectedPackageName! Item was removed: - ----- Method: PackagePaneBrowser>>packageClasses (in category 'class list') ----- - packageClasses - ^ self categoryExistsForPackage - ifFalse: [Array new] - ifTrue: - [systemOrganizer listAtCategoryNumber: - (systemOrganizer categories indexOf: self package asSymbol)]! Item was removed: - ----- Method: PackagePaneBrowser>>packageList (in category 'package list') ----- - packageList - "Answer a list of the packages in the current system organization." - - | str stream | - str := Set new: 100. - stream := WriteStream on: (Array new: 100). - systemOrganizer categories do: - [ :categ | | cats | - cats := categ asString copyUpTo: $-. - (str includes: cats) ifFalse: - [str add: cats. - stream nextPut: cats]]. - ^stream contents! Item was removed: - ----- Method: PackagePaneBrowser>>packageListIndex (in category 'package list') ----- - packageListIndex - "Answer the index of the current package selection." - - ^packageListIndex! Item was removed: - ----- Method: PackagePaneBrowser>>packageListIndex: (in category 'package list') ----- - packageListIndex: anInteger - "Set anInteger to be the index of the current package selection." - - packageListIndex := anInteger. - anInteger = 0 - ifFalse: [package := self packageList at: packageListIndex]. - selectedMessageCategoryName := nil. - self selectSystemCategory: nil. - selectedMessageName := nil. - selectedClassName := nil. - self setClassOrganizer. - self changed: #packageSelectionChanged. - self changed: #packageListIndex. "update my selection" - self changed: #systemCategoryList. "update the category list" - self selectSystemCategory: nil. "update category list selection" - ! Item was removed: - ----- Method: PackagePaneBrowser>>packageListKey:from: (in category 'package list') ----- - packageListKey: aChar from: view - aChar == $f ifTrue: [^ self findClass]. - aChar == $b ifTrue: [^ self recent]. - ^ self classListKey: aChar from: view! Item was removed: - ----- Method: PackagePaneBrowser>>packageMenu: (in category 'package list') ----- - packageMenu: aMenu - - ^ self menu: aMenu for: #(packageListMenu packageListMenuShifted:)! Item was removed: - ----- Method: PackagePaneBrowser>>restoreToPackage:category:className:protocol:selector:mode:meta: (in category 'multi-window support') ----- - restoreToPackage: packageNameOrNil category: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool - self packageListIndex: (self packageList indexOf: packageNameOrNil). - super restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool! Item was removed: - ----- Method: PackagePaneBrowser>>saveMultiWindowState (in category 'multi-window support') ----- - saveMultiWindowState - ^Message - selector: #restoreToPackage:category:className:protocol:selector:mode:meta: - arguments: { self package. - self selectedSystemCategory. - self selectedClassName. - self selectedMessageCategoryName. - self selectedMessageName. - self editSelection. - self metaClassIndicated }! Item was removed: - ----- Method: PackagePaneBrowser>>selectCategoryForClass: (in category 'system category list') ----- - selectCategoryForClass: theClass - "Set the package and category lists to display the given class." - - | cat catName | - cat := theClass category. - self packageListIndex: (self packageList indexOf: (cat copyUpTo: $-)). - catName := (cat copyFrom: ((cat indexOf: $-) + 1) to: cat size). - self selectSystemCategory: catName.! Item was removed: - ----- Method: PackagePaneBrowser>>selectPackageNamed: (in category 'package list') ----- - selectPackageNamed: aPackageName - - self packageListIndex: (self packageList indexOf: aPackageName). - self changed: #packageListIndex.! Item was removed: - ----- Method: PackagePaneBrowser>>selectedClass (in category 'class list') ----- - selectedClass - "Answer the class that is currently selected. Answer nil if no selection - exists." - - | name envt | - (name := self selectedClassName) ifNil: [^ nil]. - "(envt := self selectedEnvironment) ifNil: [^ nil]." - envt:= Smalltalk. - ^ envt at: name! Item was removed: - ----- Method: PackagePaneBrowser>>selectedPackage (in category 'package list') ----- - selectedPackage - - ^ self selectedPackageName - ifNil: [super selectedPackage] - ifNotNil: [:packageName | - self environment packageOrganizer - packageNamed: packageName - ifAbsent: [nil]]! Item was removed: - ----- Method: PackagePaneBrowser>>selectedPackageName (in category 'package list') ----- - selectedPackageName - - ^ self hasPackageSelected - ifFalse: [nil] - ifTrue: [self packageList at: packageListIndex]! Item was removed: - ----- Method: PackagePaneBrowser>>selectedSystemCategory (in category 'system category list') ----- - selectedSystemCategory - "Answer the name of the selected system category or nil." - - self hasSystemCategorySelected - ifFalse: [^nil]. - packageListIndex = 0 - ifTrue: [^ super selectedSystemCategory ]. - ^ self package , '-' , super selectedSystemCategory! Item was removed: - ----- Method: PackagePaneBrowser>>systemCategoryList (in category 'system category list') ----- - systemCategoryList - "Answer the sequenceable collection containing the class categories that - the receiver accesses." - - | prefix | - packageListIndex = 0 ifTrue: [^ systemOrganizer categories]. - prefix := self package, '-'. - ^ Array streamContents: - [:strm | - systemOrganizer categories do: - [ :cat | (cat beginsWith: prefix) ifTrue: - [strm nextPut: (cat copyFrom: prefix size + 1 to: cat size)]]]! Item was removed: - ----- Method: PackagePaneBrowser>>systemCategoryListIndex (in category 'system category list') ----- - systemCategoryListIndex - "Answer the index of the selected class category." - - ^ self systemCategoryList indexOf: super selectedSystemCategory.! Item was removed: - ----- Method: PackagePaneBrowser>>systemOrganizer: (in category 'initialize-release') ----- - systemOrganizer: aSystemOrganizer - "Initialize the receiver as a perspective on the system organizer, - aSystemOrganizer. Typically there is only one--the system variable - SystemOrganization." - - super systemOrganizer: aSystemOrganizer . - packageListIndex := 0! Item was removed: - ----- Method: PackagePaneBrowser>>updatePackages (in category 'package list') ----- - updatePackages - "Update the contents of the package list." - - self editSelection: #none. - self changed: #packageList. - self changed: #package. - self packageListIndex: 0 ! Item was removed: - ----- Method: PasteUpMorph>>defaultDesktopCommandKeyTriplets (in category '*Tools') ----- - defaultDesktopCommandKeyTriplets - "Answer a list of triplets of the form - <key> <receiver> <selector> [+ optional fourth element, a <description> for use in desktop-command-key-help] - that will provide the default desktop command key handlers. If the selector takes an argument, that argument will be the command-key event" - "World initializeDesktopCommandKeySelectors" - - | noviceKeys expertKeys | - - noviceKeys := { - {$o. self. #activateObjectsTool. 'Activate the "Objects Tool"' translated}. - {$r. self. #restoreMorphicDisplay. 'Redraw the screen' translated}. - {$z. self. #undoOrRedoCommand. 'Undo or redo the last undoable command' translated}. - {$F. Project current. #toggleFlapsSuppressed. 'Toggle the display of flaps' translated}. - {$N. self. #toggleClassicNavigatorIfAppropriate. 'Show/Hide the classic Navigator, if appropriate' translated}. - {$M. self. #toggleShowWorldMainDockingBar. 'Show/Hide the Main Docking Bar' translated}. - {$]. Smalltalk. #saveSession. 'Save the image.' translated}. - }. - - Preferences noviceMode ifTrue: [^ noviceKeys]. - - expertKeys := { - {$b. SystemBrowser. #defaultOpenBrowser. 'Open a new System Browser' translated}. - {$k. Workspace. #open. 'Open a new Workspace' translated}. - {$m. self. #putUpNewMorphMenu. 'Put up the "New Morph" menu' translated}. - {$O. self. #findAMonticelloBrowser. 'Bring a Monticello window into focus.' translated}. - {$t. self. #findATranscript:. 'Make a System Transcript visible' translated}. - {$w. SystemWindow. #closeTopWindow. 'Close the topmost window' translated}. - {Character escape. SystemWindow. #closeTopWindow. 'Close the topmost window' translated}. - - {$C. self. #findAChangeSorter:. 'Make a Change Sorter visible' translated}. - - {$L. self. #findAFileList:. 'Make a File List visible' translated}. - {$P. self. #findAPreferencesPanel:. 'Activate the Preferences tool' translated}. - {$R. Utilities. #browseRecentSubmissions. 'Make a Recent Submissions browser visible' translated}. - - {$W. self. #findAMessageNamesWindow:. 'Make a MessageNames tool visible' translated}. - {$Z. ChangeList. #browseRecentLog. 'Browse recently-logged changes' translated}. - - {$\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back' translated}. - {$_. Smalltalk. #quitPrimitive. 'Quit the image immediately.' translated}. - - {$-. Preferences. #decreaseFontSize. 'Decrease all font sizes' translated}. - {$+. Preferences. #increaseFontSize. 'Increase all font sizes' translated}. - }. - - ^ noviceKeys, expertKeys! Item was removed: - ----- Method: PasteUpMorph>>findAMonticelloBrowser (in category '*Tools') ----- - findAMonticelloBrowser - (Smalltalk classNamed: #MCWorkingCopyBrowser) ifNotNil: - [:mc| - self - findAWindowSatisfying: [:aWindow | aWindow model isMemberOf: mc] - orMakeOneUsing: [mc open]]! Item was removed: - FileList subclass: #PluggableFileList - instanceVariableNames: 'accepted fileFilterBlock canAcceptBlock validateBlock newFiles prompt resultBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - - !PluggableFileList commentStamp: 'eem 3/30/2017 17:30' prior: 0! - I am a model for a modal dialog akin to "Standard File Services" on various modern GUI operating systems. My protocol includes some methods to maintain upward compatibility with StandardFileMenu, which I hope to replace. - - Sample doIts: - - "StandardFileDialog getFolder"-- ask user to select folder, answer corresponding FileDirectory - "StandardFileDialog getFile" -- ask user to select file, answer corresponding FileStream - "StandardFileDialog putFile" -- ask user to create new file, answer FileStream - - In addition to the instance variables inhereted from FileList, of which I am a subclass, I am pluggable via the following instance variables: - - prompt <String> - Display a prompt between the buttons. - - resultBlock <BlockClosure> - Passed a file directory and a file name, answer the result to be answered by the dialog. - - canAcceptBlock <BlockClosure> - Answer whether the accept button should be "active" - - fileFilterBlock <BlockClosure> - Passed a file directory entry, answer whether the entry should be added to the list. The list can be further filtered (but not expanded) by the user through the pattern. - - validateBlock <BlockClosure> - Passed a file directory entry, a file name and a collection of newly created files, answer whether the dialog selection is valid. validateBlock is checked after the user has pressed accept, for example to ask if the user really meant to delete a file. - - newFiles <OrderedCollection> - - newFiles is an OrderedCollection of fileNames of files added by the user to the current directory since the user last entered same! Item was removed: - ----- Method: PluggableFileList class>>allFilesAndFoldersFileFilter (in category 'fileFilterBlocks') ----- - allFilesAndFoldersFileFilter - - ^[:each | true]! Item was removed: - ----- Method: PluggableFileList class>>allFoldersFileFilter (in category 'fileFilterBlocks') ----- - allFoldersFileFilter - - ^[:each | each isDirectory]! Item was removed: - ----- Method: PluggableFileList class>>alwaysAcceptBlock (in category 'canAcceptBlocks') ----- - alwaysAcceptBlock - - ^[:theDirectory :theFileName | true]! Item was removed: - ----- Method: PluggableFileList class>>alwaysValidateBlock (in category 'validateBlocks') ----- - alwaysValidateBlock - - ^[:theDirectory :theFileName :theNewFiles | true].! Item was removed: - ----- Method: PluggableFileList class>>checkExistingFileValidateBlock (in category 'validateBlocks') ----- - checkExistingFileValidateBlock - - ^[:theDirectory :theFileName :theNewFiles | - (theNewFiles includes: theFileName) or: - [(PluggableFileList okToOverwrite: theFileName)]].! Item was removed: - ----- Method: PluggableFileList class>>directoryResultBlock (in category 'resultBlocks') ----- - directoryResultBlock - - ^[:theDirectory :theFileName | theDirectory]! Item was removed: - ----- Method: PluggableFileList class>>existingFileValidateBlock (in category 'validateBlocks') ----- - existingFileValidateBlock - - ^[:theDirectory :theFileName :theNewFiles | - (theNewFiles includes: theFileName) or: - [(PluggableFileList okToOverwrite: theFileName)]].! Item was removed: - ----- Method: PluggableFileList class>>fileNameResultBlock (in category 'resultBlocks') ----- - fileNameResultBlock - - ^[:theDirectory :theFileName | theFileName]! Item was removed: - ----- Method: PluggableFileList class>>fileNameSelectedAcceptBlock (in category 'canAcceptBlocks') ----- - fileNameSelectedAcceptBlock - - ^[:theDirectory :theFileName | theFileName notNil]! Item was removed: - ----- Method: PluggableFileList class>>getFile (in category 'standard dialog operations') ----- - getFile - | result | - - self flag: #unused. - result := self getFilePathName. - ^result ifNotNil: [FileStream oldFileNamed: result]! Item was removed: - ----- Method: PluggableFileList class>>getFilePathName (in category 'standard dialog operations') ----- - getFilePathName - - ^self getFilePathNameDialog open! Item was removed: - ----- Method: PluggableFileList class>>getFilePathNameDialog (in category 'instance creation') ----- - getFilePathNameDialog - - ^(self new) - validateBlock: PluggableFileList alwaysValidateBlock; - yourself! Item was removed: - ----- Method: PluggableFileList class>>getFilePathNameDialogWithExistenceCheck (in category 'instance creation') ----- - getFilePathNameDialogWithExistenceCheck - - ^(self new) - prompt: 'Select New File:'; - validateBlock: PluggableFileList checkExistingFileValidateBlock; - yourself! Item was removed: - ----- Method: PluggableFileList class>>getFilePathNameWithExistenceCheck (in category 'standard dialog operations') ----- - getFilePathNameWithExistenceCheck - - ^self getFilePathNameDialogWithExistenceCheck open! Item was removed: - ----- Method: PluggableFileList class>>getFolder (in category 'standard dialog operations') ----- - getFolder - - ^self getFolderDialog open! Item was removed: - ----- Method: PluggableFileList class>>getFolderDialog (in category 'instance creation') ----- - getFolderDialog - - ^(self new) - prompt: 'Select a Folder'; - fileFilterBlock: PluggableFileList allFoldersFileFilter; - canAcceptBlock: PluggableFileList alwaysAcceptBlock; - resultBlock: PluggableFileList directoryResultBlock; - validateBlock: PluggableFileList alwaysValidateBlock; - yourself! Item was removed: - ----- Method: PluggableFileList class>>okToOpen:without: (in category 'validateBlocks') ----- - okToOpen: aFileNameString without: aSuffixString - - "Answer whether user confirms that it is ok to overwrite the file named in aString" - ^ 1 = (Project uiManager - chooseOptionFrom: #('overwrite that file' 'select another file') - title: aFileNameString, ' already exists.'). - ! Item was removed: - ----- Method: PluggableFileList class>>okToOverwrite: (in category 'validateBlocks') ----- - okToOverwrite: aString - - "Answer whether user confirms that it is ok to overwrite the file named in aString" - ^ 1 = (Project uiManager - chooseOptionFrom: #('overwrite that file' 'select another file') - title: aString, ' already exists.') - ! Item was removed: - ----- Method: PluggableFileList class>>open (in category 'instance creation') ----- - open - - ^self new open! Item was removed: - ----- Method: PluggableFileList class>>pathNameResultBlock (in category 'resultBlocks') ----- - pathNameResultBlock - - ^[:theDirectory :theFileName | - theFileName - ifNil: [theDirectory pathName] - ifNotNil: [theDirectory fullNameFor: theFileName]]. - ! Item was removed: - ----- Method: PluggableFileList class>>putFile (in category 'standard dialog operations') ----- - putFile - - | result | - result := self getFilePathNameWithExistenceCheck. - ^result ifNotNil: - [FileDirectory deleteFilePath: result. - FileStream newFileNamed: result]! Item was removed: - ----- Method: PluggableFileList>>addNew:byEvaluating: (in category 'file list menu') ----- - addNew: aString byEvaluating: aBlock - "A parameterization of earlier versions of #addNewDirectory and - #addNewFile. Fixes the bug in each that pushing the cancel button - in the FillInTheBlank dialog gave a walkback." - - | response newName index ending | - self okToChange ifFalse: [^ self]. - (response := UIManager default request: 'New ',aString,' Name?' - initialAnswer: aString,'Name') - isEmpty ifTrue: [^ self]. - newName := response asFileName. - Cursor wait showWhile: [ - aBlock value: newName]. - self updateFileList. - index := list indexOf: newName. - index = 0 ifTrue: [ending := ') ',newName. - index := list findFirst: [:line | line endsWith: ending]]. - self fileListIndex: index. - newFiles add: newName - ! Item was removed: - ----- Method: PluggableFileList>>beAccepted (in category 'accessing') ----- - beAccepted - - ^accepted := true! Item was removed: - ----- Method: PluggableFileList>>canAccept (in category 'accessing') ----- - canAccept - - ^canAcceptBlock value: directory value: fileName! Item was removed: - ----- Method: PluggableFileList>>canAcceptBlock: (in category 'accessing') ----- - canAcceptBlock: aBlock - - ^canAcceptBlock := aBlock! Item was removed: - ----- Method: PluggableFileList>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ Color lightYellow! Item was removed: - ----- Method: PluggableFileList>>fileFilterBlock: (in category 'accessing') ----- - fileFilterBlock: aBlock - - ^fileFilterBlock := aBlock! Item was removed: - ----- Method: PluggableFileList>>fileListIndex (in category 'accessing') ----- - fileListIndex - - self changed: #fileString. - ^super fileListIndex! Item was removed: - ----- Method: PluggableFileList>>fileSelectedMenu: (in category 'file list menu') ----- - fileSelectedMenu: aMenu - | firstItems secondItems thirdItems n1 n2 n3 services | - firstItems := self itemsForFile: self fullName asLowercase. - secondItems := self itemsForAnyFile. - thirdItems := self itemsForNoFile. - n1 := firstItems size. - n2 := n1 + secondItems size. - n3 := n2 + thirdItems size. - services := firstItems, secondItems, thirdItems, - (OrderedCollection with: (SimpleServiceEntry provider: self label: 'more...' selector: #offerAllFileOptions)). - ^ aMenu - addServices2: services - for: self - extraLines: (Array with: n1 with: n2 with: n3) - ! Item was removed: - ----- Method: PluggableFileList>>fileString (in category 'file string') ----- - fileString - - fileName ifNil: [^directory pathName]. - ^directory fullNameFor: fileName! Item was removed: - ----- Method: PluggableFileList>>fileString: (in category 'file string') ----- - fileString: aString - - "| textName index ending | - textName := aString asString. - (FileDirectory default fileExists: textName) ifTrue: - [self directory: (FileDirectory forFileName: textName). - index := list indexOf: (FileDirectory localNameFor: textName). - index = 0 ifTrue: - [ending := ') ', (FileDirectory localNameFor: textName). - index := list findFirst: [:line | line endsWith: ending]]. - self fileListIndex: index]. - (FileDirectory default directoryExists: textName) ifTrue: - [self directory: (FileDirectory on: textName)]." - self changed: #fileString. - self changed: #contents. - ^true! Item was removed: - ----- Method: PluggableFileList>>fileVolumeIndex (in category 'accessing') ----- - fileVolumeIndex - - self changed: #fileString. - ^super fileVolumeIndex! Item was removed: - ----- Method: PluggableFileList>>initialize (in category 'initialize-release') ----- - initialize - - super initialize. - prompt := 'Select File'. - directory := FileDirectory default. - newFiles := OrderedCollection new. - fileFilterBlock := PluggableFileList allFilesAndFoldersFileFilter. - canAcceptBlock := PluggableFileList fileNameSelectedAcceptBlock. - resultBlock := PluggableFileList pathNameResultBlock. - validateBlock := PluggableFileList checkExistingFileValidateBlock. - ! Item was removed: - ----- Method: PluggableFileList>>leftButtonPressed (in category 'accepting/cancelling') ----- - leftButtonPressed - - accepted := false. - self changed: #close. - ! Item was removed: - ----- Method: PluggableFileList>>leftButtonState (in category 'accepting/cancelling') ----- - leftButtonState - - ^true! Item was removed: - ----- Method: PluggableFileList>>listForPattern: (in category 'file list menu') ----- - listForPattern: pat - "Make the list be those file names which match the pattern." - | entries sizePad newList allFiles | - entries := directory entries select: fileFilterBlock. - sizePad := (entries inject: 0 into: [:mx :entry | mx max: entry fileSize]) - asStringWithCommas size - 1. - - newList := OrderedCollection new: entries size. - - allFiles := pat = '*'. - entries do: - [:entry | "<dirflag><name><creationTime><modificationTime><fileSize>" - (allFiles or: [entry isDirectory or: [pat match: entry name]]) ifTrue: - [newList add: entry]]. - newList := newList asArray sort: self sortBlock. - newList := newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. - - volList size = 1 ifTrue: - ["Include known servers along with other desktop volumes" - ^newList , - (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])]. - newFiles := OrderedCollection new. - ^ newList! Item was removed: - ----- Method: PluggableFileList>>open (in category 'initialize-release') ----- - open - self deprecated: 'PluggableFileList is being deprecated'. "This can go away soon" - - ^ Project uiManager openPluggableFileList: self label: prompt in: self currentWorld! Item was removed: - ----- Method: PluggableFileList>>prompt: (in category 'accessing') ----- - prompt: aString - - prompt := aString! Item was removed: - ----- Method: PluggableFileList>>result (in category 'accepting/cancelling') ----- - result - - accepted ifFalse: [^nil]. - ^resultBlock value: directory value: fileName! Item was removed: - ----- Method: PluggableFileList>>resultBlock: (in category 'accessing') ----- - resultBlock: aBlock - - ^resultBlock := aBlock! Item was removed: - ----- Method: PluggableFileList>>rightButtonPressed (in category 'accepting/cancelling') ----- - rightButtonPressed - - (canAcceptBlock value: directory value: fileName) ifFalse: [^nil]. - (validateBlock value: directory value: fileName value: newFiles) ifFalse: [^nil]. - accepted := true. - self changed: #close! Item was removed: - ----- Method: PluggableFileList>>rightButtonState (in category 'accepting/cancelling') ----- - rightButtonState - - ^self canAccept! Item was removed: - ----- Method: PluggableFileList>>startUpWithCaption: (in category 'StandardFileMenu') ----- - startUpWithCaption: captionOrNil - "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action." - - ^ self - startUpWithCaption: captionOrNil - at: (self currentHand ifNil: [Sensor]) cursorPoint! Item was removed: - ----- Method: PluggableFileList>>startUpWithCaption:at: (in category 'StandardFileMenu') ----- - startUpWithCaption: aString at: location - - self prompt: aString. - ^self open! Item was removed: - ----- Method: PluggableFileList>>validate (in category 'accessing') ----- - validate - - ^validateBlock value: directory value: fileName value: newFiles! Item was removed: - ----- Method: PluggableFileList>>validateBlock: (in category 'accessing') ----- - validateBlock: aBlock - - ^validateBlock := aBlock! Item was removed: - ----- Method: PluggableTextMorph>>canHaveUnacceptedEdits (in category '*Tools-multi-window support') ----- - canHaveUnacceptedEdits - "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)" - - ^true! Item was removed: - ----- Method: PluggableTextMorph>>saveContentsInFile (in category '*Tools-file out') ----- - saveContentsInFile - self handleEdit: [textMorph editor saveContentsInFile]! Item was removed: - ----- Method: PluggableTextMorph>>unacceptedEditState (in category '*Tools-multi-window support') ----- - unacceptedEditState - ^hasUnacceptedEdits ifTrue: [self text]! Item was removed: - ----- Method: PluggableTextMorph>>unacceptedEditState: (in category '*Tools-multi-window support') ----- - unacceptedEditState: stateOrNil - stateOrNil - ifNotNil: - [self setText: stateOrNil. - hasUnacceptedEdits := true "setText: clears hasUnacceptedEdits, so must do this post setText:"] - ifNil: [hasUnacceptedEdits := false]! Item was removed: - ObjectExplorer subclass: #PointerExplorer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Explorer'! - - !PointerExplorer commentStamp: 'avi 8/21/2004 20:01' prior: 0! - A variant on the ObjectExlorer that works "backwards": like the ObjectExplorer, it shows a tree of objects, but expanding a node won't show the objects which that node references, but rather the objects that reference that node. Its main use is to track down memory leaks: if you want to know why a particular object is still alive, open a PointerExplorer on it and drill down until you find the root object that's referencing it. For example, find all the references to the symbol #zot with: - - PointerExplorer new openExplorerFor: #zot - - For the "name" of the object, the PointerExplorer shows each object's identityHash, to allow the user to identify when two similar objects are identical and notice cycles.! Item was removed: - ----- Method: PointerExplorer class>>nodeClass (in category 'defaults') ----- - nodeClass - - ^ PointerExplorerWrapper! Item was removed: - ----- Method: PointerExplorer>>rootObject: (in category 'accessing') ----- - rootObject: anObject - self root key: 'leaf'. - super rootObject: anObject! Item was removed: - ObjectExplorerWrapper subclass: #PointerExplorerWrapper - instanceVariableNames: 'weakOnly' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Explorer'! - - !PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58' prior: 0! - A subclass of ObjectExplorerWrapper for use with PointerExplorer. #contents is overridden to work backwards: it returns wrappers for the objects pointing to item rather than for the objects that item points to.! Item was removed: - ----- Method: PointerExplorerWrapper>>asString (in category 'converting') ----- - asString - - ^ self object identityHash asString, ': ', super asString.! Item was removed: - ----- Method: PointerExplorerWrapper>>contents (in category 'accessing') ----- - contents - "Return the wrappers with the objects holding references to item. Eldest objects come first, weak only referencers are at the end and have parentheses around their identity hash." - - | objects weakOnlyReferences | - objects := self object inboundPointersExcluding: { self. self item. model }. - weakOnlyReferences := OrderedCollection new. - objects removeAllSuchThat: [ :each | - each class == self class - or: [ each class == PointerExplorer - or: [ (each isContext - and: [ (each objectClass: each receiver) == PointerExplorer ] ) - or: [ (each pointsOnlyWeaklyTo: self object) - ifTrue: [ weakOnlyReferences add: each. true ] - ifFalse: [ false ] ] ] ] ]. - ^(objects replace: [ :each | - self class with: each name: (self nameForParent: each) model: self object ]) - addAll: (weakOnlyReferences replace: [ :each | - (self class with: each name: '(', (self nameForParent: each), ')' model: self object) - weakOnly: true; - yourself ]); - yourself! Item was removed: - ----- Method: PointerExplorerWrapper>>hasContents (in category 'testing') ----- - hasContents - ^true! Item was removed: - ----- Method: PointerExplorerWrapper>>isWeakOnly (in category 'testing') ----- - isWeakOnly - - ^weakOnly ifNil: [ false ] "This #ifNil: message is only here to avoid errors when updating an image with opened PointerExplorers."! Item was removed: - ----- Method: PointerExplorerWrapper>>memberNameFrom:to: (in category 'accessing') ----- - memberNameFrom: aParent to: aChild - - 1 to: aParent class instSize do: [ :instVarIndex | - (aParent instVarAt: instVarIndex) == aChild - ifTrue: [ ^ '''', (aParent class instVarNameForIndex: instVarIndex), '''' ]]. - - "This covers compiled methods and compiled blocks." - aParent isCompiledCode ifTrue: [ - 1 to: aParent numLiterals do: [ :index | - (aParent literalAt: index) == aChild - ifTrue: [^ 'literal', index asString]]]. - - "This also covers arrays" - 1 to: aParent basicSize do: [ :index | - (aParent basicAt: index) == aChild - ifTrue: [^ index asString]]. - ^ '???'! Item was removed: - ----- Method: PointerExplorerWrapper>>nameForParent: (in category 'accessing') ----- - nameForParent: anObject - - ^ self memberNameFrom: anObject to: self object! Item was removed: - ----- Method: PointerExplorerWrapper>>preferredColor (in category 'accessing') ----- - preferredColor - - ^self isWeakOnly - ifTrue: [ Color gray ] - ifFalse: [ super preferredColor ]! Item was removed: - ----- Method: PointerExplorerWrapper>>weakOnly: (in category 'accessing') ----- - weakOnly: aBoolean - - weakOnly := aBoolean! Item was removed: - Model subclass: #PointerFinder - instanceVariableNames: 'goal parents toDo toDoNext hasGemStone pointerList objectList parentsSize todoSize depth pointerListIndex excludedObjects' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !PointerFinder commentStamp: '<historical>' prior: 0! - I can search for reasons why a certain object isn't garbage collected. I'm a quick port of a VisualWorks program written by Hans-Martin Mosner. Call me as shown below. I'll search for a path from a global variable to the given object, presenting it in a small morphic UI. - - Examples: - PointerFinder on: self currentHand - PointerFinder on: StandardSystemView someInstance - - Now, let's see why this image contains more HandMorphs as expected... - - HandMorph allInstancesDo: [:e | PointerFinder on: e]! Item was removed: - ----- Method: PointerFinder class>>on: (in category 'instance creation') ----- - on: anObject - ^ self - on: anObject - except: Array empty! Item was removed: - ----- Method: PointerFinder class>>on:except: (in category 'instance creation') ----- - on: anObject except: aCollection - ^ self new - goal: anObject; - excludedObjects: aCollection; - search; - open! Item was removed: - ----- Method: PointerFinder class>>pointersTo: (in category 'utilities') ----- - pointersTo: anObject - "Find all occurrences in the system of pointers to the argument anObject." - "(PointerFinder pointersTo: Browser) inspect." - - ^ self pointersTo: anObject except: #() - ! Item was removed: - ----- Method: PointerFinder class>>pointersTo:except: (in category 'utilities') ----- - pointersTo: anObject except: objectsToExclude - "Find all occurrences in the system of pointers to the argument anObject. - Remove objects in the exclusion list from the results." - - ^ anObject inboundPointersExcluding: objectsToExclude! Item was removed: - ----- Method: PointerFinder class>>pointersToItem:of: (in category 'utilities') ----- - pointersToItem: index of: anArray - "Find all occurrences in the system of pointers to the given element of the given array. - This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate: - - PointerFinder pointersToItem: 2 of: self - - in the inspector." - - ^ self pointersTo: (anArray at: index) except: (Array with: anArray)! Item was removed: - ----- Method: PointerFinder>>arrowKey:from: (in category 'pointer-list') ----- - arrowKey: key from: aController - key = $i ifTrue: [^ self inspectObject]. - ^ super arrowKey: key from: aController! Item was removed: - ----- Method: PointerFinder>>buildList (in category 'initialize-release') ----- - buildList - | list obj parent object key | - list := OrderedCollection new. - obj := goal. - - [list addFirst: obj. - obj := parents at: obj ifAbsent: []. - obj == nil] whileFalse. - list removeFirst. - parent := Smalltalk. - objectList := OrderedCollection new. - pointerList := OrderedCollection new. - [list isEmpty] - whileFalse: - [object := list removeFirst. - key := nil. - (parent isKindOf: Dictionary) - ifTrue: [list size >= 2 - ifTrue: - [key := parent keyAtValue: list second ifAbsent: []. - key == nil - ifFalse: - [object := list removeFirst; removeFirst. - pointerList add: key printString , ' -> ' , object class name]]]. - key == nil - ifTrue: - [parent class == object ifTrue: [key := 'CLASS']. - key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i) - == object ifTrue: [key := parent class instVarNameForIndex: i]]]]. - key == nil ifTrue: [parent isCompiledCode ifTrue: [key := 'literals?']]. - key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i) - == object ifTrue: [key := i printString]]]]. - key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']]. - key == nil ifTrue: [key := '???']. - pointerList add: key , ': ' , object class name, (object isMorph ifTrue: [' (', object identityHash asString, ')'] ifFalse: [ String empty ]) ]. - objectList add: object. - parent := object]! Item was removed: - ----- Method: PointerFinder>>buildWith: (in category 'ui-building') ----- - buildWith: builder - | listSpec windowSpec | - windowSpec := builder pluggableWindowSpec new - model: self; - label: 'Pointer Finder'. - - listSpec := builder pluggableListSpec new - model: self; - frame: (0 at 0 corner: 1 at 1); - list: #pointerList; - getIndex: #pointerListIndex; - setIndex: #pointerListIndex:; - menu: #menu:shifted:; - keyPress: #arrowKey:from:; - doubleClick: #inspectObject; - yourself. - - windowSpec children: {listSpec}. - - ^ builder build: windowSpec.! Item was removed: - ----- Method: PointerFinder>>excludedObjects (in category 'accessing') ----- - excludedObjects - ^ excludedObjects! Item was removed: - ----- Method: PointerFinder>>excludedObjects: (in category 'initialize-release') ----- - excludedObjects: aCollection - excludedObjects := aCollection asIdentitySet! Item was removed: - ----- Method: PointerFinder>>follow:from: (in category 'private') ----- - follow: anObject from: parentObject - anObject == goal ifTrue: - [ parents - at: anObject - put: parentObject. - ^ true ]. - anObject shouldFollowOutboundPointers ifFalse: [ ^ false ]. - ((parents includesKey: anObject) or: [ anObject class = self class ]) ifTrue: [ ^ false ]. - parents - at: anObject - put: parentObject. - toDoNext add: anObject. - ^ false! Item was removed: - ----- Method: PointerFinder>>followObject: (in category 'private') ----- - followObject: anObject - - (self excludedObjects includes: anObject) - ifTrue: [^ false]. - anObject outboundPointersDo: [:ea | - (self follow: ea from: anObject) - ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: PointerFinder>>goal: (in category 'initialize-release') ----- - goal: anObject - goal := anObject! Item was removed: - ----- Method: PointerFinder>>initialExtent (in category 'ui-building') ----- - initialExtent - ^ 300 @ 300! Item was removed: - ----- Method: PointerFinder>>initialize (in category 'initialize-release') ----- - initialize - parents := IdentityDictionary new: 20000. - parents at: Smalltalk put: nil. - parents at: Processor put: nil. - parents at: self put: nil. - - toDo := OrderedCollection new: 5000. - toDo add: Smalltalk. - toDoNext := OrderedCollection new: 5000. - - excludedObjects := IdentitySet new! Item was removed: - ----- Method: PointerFinder>>inspectObject (in category 'pointer-list') ----- - inspectObject - pointerListIndex = 0 ifTrue: [^ Beeper beep]. - (objectList at: pointerListIndex) inspect! Item was removed: - ----- Method: PointerFinder>>menu:shifted: (in category 'pointer-list') ----- - menu: aMenu shifted: shifted - - ^ self menu: aMenu for: #(pointerListMenu pointerListMenuShifted:) shifted: shifted! Item was removed: - ----- Method: PointerFinder>>open (in category 'ui-building') ----- - open - ^ ToolBuilder open: self.! Item was removed: - ----- Method: PointerFinder>>openInMorphic (in category 'morphic ui') ----- - openInMorphic - | window list | - window := (SystemWindow labelled: 'Pointer Finder') - model: self. - list := PluggableListMorph new - doubleClickSelector: #inspectObject; - - on: self - list: #pointerList - selected: #pointerListIndex - changeSelected: #pointerListIndex: - menu: #menu:shifted: - keystroke: #arrowKey:from:. - "For doubleClick to work best disable autoDeselect" - list autoDeselect: false. - window addMorph: list frame: (0 at 0 extent: 1 at 1). - list color: Color lightMagenta. - window openInWorld! Item was removed: - ----- Method: PointerFinder>>pointerList (in category 'pointer-list') ----- - pointerList - ^ pointerList asArray! Item was removed: - ----- Method: PointerFinder>>pointerListIndex (in category 'pointer-list') ----- - pointerListIndex - ^ pointerListIndex ifNil: [0]! Item was removed: - ----- Method: PointerFinder>>pointerListIndex: (in category 'pointer-list') ----- - pointerListIndex: anInteger - pointerListIndex := anInteger. - self changed: #pointerListIndex! Item was removed: - ----- Method: PointerFinder>>pointerListMenu: (in category 'pointer-list') ----- - pointerListMenu: aMenu - - <pointerListMenu> - ^ aMenu - addList: #( - ('Inspect (i)' #inspectObject 'Live long and prosper!!') - - - ('Search again' #searchAgain 'Search again\for the same object' withCRs)); - yourself.! Item was removed: - ----- Method: PointerFinder>>search (in category 'application') ----- - search - Smalltalk garbageCollect. - - self initialize. - - Cursor wait showWhile: [ - [[toDo isEmpty or: [self followObject: toDo removeFirst]] whileFalse. - toDo isEmpty and: [toDoNext isEmpty not]] - whileTrue: - [toDo := toDoNext. - toDoNext := OrderedCollection new: 5000]]. - - self buildList! Item was removed: - ----- Method: PointerFinder>>searchAgain (in category 'pointer-list') ----- - searchAgain - self pointerListIndex: 0. - self search. - self changed: #pointerList! Item was removed: - ----- Method: PointerFinder>>update (in category 'application') ----- - update - ('done: ' , parents size asString , ' todo: ' , toDo size asString , ' ') displayAt: 0 at 0! Item was removed: - Object subclass: #PopUpMenu - instanceVariableNames: 'labelString font lineArray frame form marker selection' - classVariableNames: 'CacheMenuForms' - poolDictionaries: '' - category: 'Tools-Menus'! - - !PopUpMenu commentStamp: '<historical>' prior: 0! - I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection.! Item was removed: - ----- Method: PopUpMenu class>>cleanUp (in category 'class initialization') ----- - cleanUp - "Re-initialize" - - self initialize.! Item was removed: - ----- Method: PopUpMenu class>>confirm: (in category 'dialogs') ----- - confirm: queryString - "Put up a yes/no menu with caption queryString. Answer true if the - response is yes, false if no. This is a modal question--the user must - respond yes or no." - - "PopUpMenu confirm: 'Are you hungry?'" - - ^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated! Item was removed: - ----- Method: PopUpMenu class>>confirm:orCancel: (in category 'dialogs') ----- - confirm: queryString orCancel: cancelBlock - "Put up a yes/no/cancel menu with caption aString. Answer - true if - the response is yes, false if no. If cancel is chosen, evaluate - cancelBlock. This is a modal question--the user must respond - yes or no." - "PopUpMenu confirm: 'Reboot universe' orCancel: - [^'Nevermind'] " - | menu choice | - menu := PopUpMenu labelArray: {'Yes' translated. 'No' translated. 'Cancel' translated}. - choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon. - choice = 1 - ifTrue: [^ true]. - choice = 2 - ifTrue: [^ false]. - ^ cancelBlock value! Item was removed: - ----- Method: PopUpMenu class>>confirm:trueChoice:falseChoice: (in category 'dialogs') ----- - confirm: queryString trueChoice: trueChoice falseChoice: falseChoice - "Put up a yes/no menu with caption queryString. The actual - wording - for the two choices will be as provided in the trueChoice and - falseChoice parameters. Answer true if the response is the - true-choice, - false if it's the false-choice. - This is a modal question -- the user must respond one way or - the other." - "PopUpMenu - confirm: 'Are you hungry?' - trueChoice: 'yes, I''m famished' - falseChoice: 'no, I just ate'" - | menu choice | - menu := PopUpMenu labelArray: {trueChoice. falseChoice}. - [(choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon) isNil] whileTrue. - ^ choice = 1! Item was removed: - ----- Method: PopUpMenu class>>inform: (in category 'dialogs') ----- - inform: aString - "PopUpMenu inform: 'I like Squeak'" - - | iconOrNil | - iconOrNil := Smalltalk at: #MenuIcons ifPresent: [:cls | cls confirmIcon]. - (PopUpMenu labels: ' OK ' translated) - startUpWithCaption: aString - icon: iconOrNil - ! Item was removed: - ----- Method: PopUpMenu class>>labelArray: (in category 'instance creation') ----- - labelArray: labelArray - "Answer an instance of me whose items are in labelArray." - - ^ self labelArray: labelArray lines: nil! Item was removed: - ----- Method: PopUpMenu class>>labelArray:lines: (in category 'instance creation') ----- - labelArray: labelArray lines: lineArray - "Answer an instance of me whose items are in labelArray, with lines - drawn after each item indexed by anArray. 2/1/96 sw" - - labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size']. - ^ self - labels: (String streamContents: - [:stream | - labelArray do: [:each | stream nextPutAll: each; cr]. - stream skip: -1 "remove last CR"]) - lines: lineArray - - "Example: - (PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #()) startUp"! Item was removed: - ----- Method: PopUpMenu class>>labels: (in category 'instance creation') ----- - labels: aString - "Answer an instance of me whose items are in aString." - - ^ self labels: aString lines: nil! Item was removed: - ----- Method: PopUpMenu class>>labels:lines: (in category 'instance creation') ----- - labels: aString lines: anArray - "Answer an instance of me whose items are in aString, with lines drawn - after each item indexed by anArray." - - ^ self new - labels: aString - font: Preferences standardMenuFont - lines: anArray! Item was removed: - ----- Method: PopUpMenu class>>notify: (in category 'dialogs') ----- - notify: message - "Deprecated. Use #inform: instead." - - self inform: message! Item was removed: - ----- Method: PopUpMenu class>>standardMenuStyle (in category 'class initialization') ----- - standardMenuStyle - - ^ (TextStyle fontArray: { Preferences standardMenuFont }) - centered; - yourself! Item was removed: - ----- Method: PopUpMenu class>>withCaption:chooseFrom: (in category 'instance creation') ----- - withCaption: cap chooseFrom: labels - "Simply put up a menu. Get the args in the right order with the caption - first. labels may be either an array of items or a string with CRs in it. - May use backslashes for returns." - - ^ (labels isString - ifTrue: [self labels: labels withCRs lines: nil] - ifFalse: [self labelArray: labels lines: nil]) - startUpWithCaption: cap withCRs! Item was removed: - ----- Method: PopUpMenu>>center (in category 'accessing') ----- - center - "Answer the point at the center of the receiver's rectangular area." - - ^ frame center! Item was removed: - ----- Method: PopUpMenu>>computeForm (in category 'private') ----- - computeForm - "Compute and answer a Form to be displayed for this menu." - - | borderInset paraForm menuForm menuStyle inside | - borderInset := 4 at 4. - menuStyle := self class standardMenuStyle. - paraForm := ((DisplayText text: labelString asText textStyle: menuStyle) - foregroundColor: (self userInterfaceTheme textColor ifNil: [Color black]) - backgroundColor: (self userInterfaceTheme color ifNil: [Color white])) form. - menuForm := Form extent: paraForm extent + (borderInset * 2) depth: paraForm depth. - menuForm fill: (0 @ 0 extent: menuForm extent) - rule: Form over - fillColor: (self userInterfaceTheme color ifNil: [Color white]). - menuForm - border: menuForm boundingBox - width: 2 - fillColor: (self userInterfaceTheme borderColor ifNil: [Color black]). - - paraForm displayOn: menuForm at: borderInset. - lineArray == nil ifFalse: - [lineArray do: - [ :line | - menuForm - fill: (4 @ ((line * font lineGrid) + borderInset y) - extent: (menuForm width - 8 @ 1)) - rule: Form over - fillColor: (self userInterfaceTheme lineColor ifNil: [Color black])]]. - - frame := Quadrangle new. - frame region: menuForm boundingBox. - frame borderWidth: 4. - inside := frame inside. - marker := inside topLeft extent: (inside width @ menuStyle lineGrid). - selection := 1. - - ^ form := menuForm - ! Item was removed: - ----- Method: PopUpMenu>>controlActivity (in category 'basic control sequence') ----- - controlActivity - "Do whatever a menu must do - now with keyboard support." - - | didNotMove downPos | - didNotMove := true. - Sensor anyButtonPressed - ifFalse: - [didNotMove := false. - Sensor waitButtonOrKeyboard]. - - Sensor keyboardPressed ifFalse: [self manageMarker]. - (didNotMove and: [selection = 0]) - ifTrue: - [downPos := Sensor cursorPoint. - [didNotMove and: [Sensor anyButtonPressed]] - whileTrue: - [ Project current world activeController interActivityPause. - (downPos dist: Sensor cursorPoint) < 2 ifFalse: [didNotMove := false]]. - didNotMove ifTrue: [Sensor waitButtonOrKeyboard]]. - - [Sensor keyboardPressed] whileTrue: - [self readKeyboard ifTrue: [^ self]. - Sensor waitButtonOrKeyboard]. - - [Sensor anyButtonPressed] whileTrue: [ - ScheduledControllers activeController interActivityPause. - self manageMarker]! Item was removed: - ----- Method: PopUpMenu>>displayAt:withCaption:during: (in category 'displaying') ----- - displayAt: aPoint withCaption: captionOrNil during: aBlock - "Display the receiver just to the right of aPoint while aBlock is evaluated. If the receiver is forced off screen, display it just to the right." - | delta savedArea captionForm captionSave outerFrame captionText tFrame frameSaveLoc captionBox | - marker ifNil: [self computeForm]. - frame := frame align: marker leftCenter with: aPoint + (2 at 0). - outerFrame := frame. - captionOrNil notNil ifTrue: - [captionText := (DisplayText - text: captionOrNil asText - textStyle: self class standardMenuStyle copy centered) - foregroundColor: (self userInterfaceTheme textColor ifNil: [Color black]) - backgroundColor: (self userInterfaceTheme color ifNil: [Color white]). - tFrame := captionText boundingBox insetBy: -2. - outerFrame := frame merge: (tFrame align: tFrame bottomCenter - with: frame topCenter + (0 at 2))]. - delta := outerFrame amountToTranslateWithin: Display boundingBox. - frame right > Display boundingBox right - ifTrue: [delta := 0 - frame width @ delta y]. - frame := frame translateBy: delta. - captionOrNil notNil ifTrue: - [captionForm := captionText form. - captionBox := captionForm boundingBox expandBy: 4. - captionBox := captionBox align: captionBox bottomCenter - with: frame topCenter + (0 at 2). - captionSave := Form fromDisplay: captionBox. - Display border: captionBox width: 4 fillColor: (self userInterfaceTheme color ifNil: [Color white]). - Display border: captionBox width: 2 fillColor: (self userInterfaceTheme textColor ifNil: [Color black]). - captionForm displayAt: captionBox topLeft + 4]. - marker := marker align: marker leftCenter with: aPoint + delta + (2 at 0). - savedArea := Form fromDisplay: frame. - self menuForm displayOn: Display at: (frameSaveLoc := frame topLeft). - selection ~= 0 ifTrue: [Display reverse: marker]. - Cursor normal showWhile: aBlock. - savedArea displayOn: Display at: frameSaveLoc. - captionOrNil notNil ifTrue: - [captionSave displayOn: Display at: captionBox topLeft]! Item was removed: - ----- Method: PopUpMenu>>frameHeight (in category 'accessing') ----- - frameHeight - "Designed to avoid the entire frame computation (includes MVC form), - since the menu may well end up being displayed in Morphic anyway." - | nItems | - frame ifNotNil: [^ frame height]. - nItems := 1 + (labelString occurrencesOf: Character cr). - ^ (nItems * self class standardMenuStyle lineGrid) + 4 "border width"! Item was removed: - ----- Method: PopUpMenu>>labelString (in category 'accessing') ----- - labelString - ^ labelString! Item was removed: - ----- Method: PopUpMenu>>labels:font:lines: (in category 'private') ----- - labels: aString font: aFont lines: anArray - - labelString := aString. - font := aFont. - lineArray := anArray. - ! Item was removed: - ----- Method: PopUpMenu>>lineArray (in category 'accessing') ----- - lineArray - ^ lineArray! Item was removed: - ----- Method: PopUpMenu>>manageMarker (in category 'marker adjustment') ----- - manageMarker - "If the cursor is inside the receiver's frame, then highlight the marked - item. Otherwise no item is to be marked." - | pt | - "Don't let pt get far from display box, so scrolling will go all the way" - pt := Sensor cursorPoint adhereTo: (Display boundingBox expandBy: 1). - (frame inside containsPoint: pt) - ifTrue: ["Need to cache the form for reasonable scrolling performance" - ((Display boundingBox insetBy: 0 at 3) containsPoint: pt) - ifFalse: [pt := pt - (self scrollIntoView: pt)]. - self markerOn: pt] - ifFalse: [self markerOff]! Item was removed: - ----- Method: PopUpMenu>>markerOff (in category 'marker adjustment') ----- - markerOff - "No item is selected. Reverse the highlight if any item has been marked - as selected." - - self setSelection: 0! Item was removed: - ----- Method: PopUpMenu>>markerOn: (in category 'marker adjustment') ----- - markerOn: aPoint - "The item whose bounding area contains aPoint should be marked as - selected. Highlight its area and set the selection to its index." - - selection = 0 | (marker containsPoint: aPoint) not - ifTrue: [selection = 0 & (marker containsPoint: aPoint) - ifTrue: [Display reverse: marker] - ifFalse: - [selection > 0 ifTrue: [Display reverse: marker]. - marker := - marker - align: marker topLeft - with: marker left @ (self markerTop: aPoint). - Display reverse: marker]]. - selection := marker top - frame top // marker height + 1! Item was removed: - ----- Method: PopUpMenu>>markerTop: (in category 'marker adjustment') ----- - markerTop: aPoint - "Answer aPoint, gridded to lines in the receiver." - - ^(aPoint y - frame inside top truncateTo: font lineGrid) + frame inside top! Item was removed: - ----- Method: PopUpMenu>>menuForm (in category 'private') ----- - menuForm - "Answer a Form to be displayed for this menu." - - form == nil ifTrue: [self computeForm]. - ^ form! Item was removed: - ----- Method: PopUpMenu>>nItems (in category 'accessing') ----- - nItems - ^ (labelString occurrencesOf: Character cr) + 1! Item was removed: - ----- Method: PopUpMenu>>readKeyboard (in category 'basic control sequence') ----- - readKeyboard - "Keyboard support for menus. ESC will abort the menu, Space or CR - will select an item. Cursor up and cursor down will change the - selection. Any other key will either select an item whose label starts - with that character or select the next matching label. - Answer true if the menu should be closed and false otherwise." - - | ch labels occurences | - ch := Sensor keyboard asciiValue. - (ch = 13 or: [ch = 32]) ifTrue: [^ true]. - ch = 27 ifTrue: [self setSelection: 0. ^ true]. - ch = 30 - ifTrue: - [self setSelection: (selection <= 1 - ifTrue: [self nItems] - ifFalse: [selection - 1])]. - ch = 31 ifTrue: [self setSelection: selection \\ self nItems + 1]. - ch := ch asCharacter asLowercase. - labels := labelString lines. - occurences := 0. - 1 + selection to: selection + labels size do: - [:index | - | i | i := index - 1 \\ labels size + 1. - (labels at: i) withBlanksTrimmed first asLowercase = ch - ifTrue: [(occurences := occurences + 1) = 1 ifTrue: [self setSelection: i]]]. - ^ occurences = 1! Item was removed: - ----- Method: PopUpMenu>>rescan (in category 'private') ----- - rescan - "Cause my form to be recomputed after a font change." - - labelString == nil ifTrue: [labelString := 'NoText!!']. - self labels: labelString font: Preferences standardMenuFont lines: lineArray. - frame := marker := form := nil. - - "PopUpMenu allSubInstancesDo: [:m | m rescan]"! Item was removed: - ----- Method: PopUpMenu>>scrollIntoView: (in category 'marker adjustment') ----- - scrollIntoView: cursorLoc - | dy | - dy := 0. - cursorLoc y < 2 ifTrue: [dy := font height]. - cursorLoc y > (Display height-3) ifTrue: [dy := font height negated]. - dy = 0 ifTrue: [^ 0 at 0]. - self markerOff. - frame := frame translateBy: 0 at dy. - marker := marker translateBy: 0 at dy. - self menuForm displayOn: Display at: frame topLeft. - ^ 0 at dy! Item was removed: - ----- Method: PopUpMenu>>selection (in category 'selecting') ----- - selection - "Answer the current selection." - - ^ selection! Item was removed: - ----- Method: PopUpMenu>>setSelection: (in category 'selecting') ----- - setSelection: index - | newSelection | - selection = index ifTrue: [^ self]. - newSelection := (0 max: index) min: frame height // marker height. - selection > 0 ifTrue: [Display reverse: marker]. - marker := marker translateBy: 0 @ (newSelection - selection * marker height). - selection := newSelection. - selection > 0 ifTrue: [Display reverse: marker]! Item was removed: - ----- Method: PopUpMenu>>startUp (in category 'basic control sequence') ----- - startUp - "Display and make a selection from the receiver as long as the button - is pressed. Answer the current selection." - - ^ self startUpWithCaption: nil! Item was removed: - ----- Method: PopUpMenu>>startUpCenteredWithCaption: (in category 'basic control sequence') ----- - startUpCenteredWithCaption: captionOrNil - "Differs from startUpWithCaption: by appearing with cursor in the menu, and thus ready to act on mouseUp, without requiring user tweak to confirm" - - ^ self - startUpWithCaption: captionOrNil - at: (self currentHand ifNil: [Sensor]) cursorPoint - (20 @ 0)! Item was removed: - ----- Method: PopUpMenu>>startUpSegmented:withCaption:at: (in category 'basic control sequence') ----- - startUpSegmented: segmentHeight withCaption: captionOrNil at: location - "This menu is too big to fit comfortably on the screen. - Break it up into smaller chunks, and manage the relative indices. - Inspired by a special-case solution by Reinier van Loon." - " - (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1]) - lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. - " - | nLines nLinesPer allLabels from to subset subLines index | - frame ifNil: [self computeForm]. - allLabels := labelString lines. - nLines := allLabels size. - lineArray ifNil: [lineArray := Array new]. - nLinesPer := segmentHeight // marker height - 3. - from := 1. - [to := (from + nLinesPer) min: nLines. - subset := allLabels copyFrom: from to: to. - subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated]) - before: subset first. - subLines := lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. - subLines := (Array with: 1) , subLines. - index := (PopUpMenu labels: subset asStringWithCr lines: subLines) - startUpWithCaption: captionOrNil at: location. - index = 1 - ifTrue: [from := to + 1. - from > nLines ifTrue: [ from := 1 ]] - ifFalse: [index = 0 ifTrue: [^ 0]. - ^ from + index - 2]] repeat! Item was removed: - ----- Method: PopUpMenu>>startUpSegmented:withCaption:at:allowKeyboard: (in category 'basic control sequence') ----- - startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean - "This menu is too big to fit comfortably on the screen. - Break it up into smaller chunks, and manage the relative indices. - Inspired by a special-case solution by Reinier van Loon. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" - - " - (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1]) - lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. - " - | nLines nLinesPer allLabels from to subset subLines index | - frame ifNil: [self computeForm]. - allLabels := labelString lines. - nLines := allLabels size. - lineArray ifNil: [lineArray := Array new]. - nLinesPer := segmentHeight // marker height - 3. - from := 1. - [to := (from + nLinesPer) min: nLines. - subset := (allLabels copyFrom: from to: to) asOrderedCollection. - subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated]) - before: subset first. - subLines := lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. - subLines := (Array with: 1) , subLines. - index := (PopUpMenu labels: subset asStringWithCr lines: subLines) - startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. - index = 1 - ifTrue: [from := to + 1. - from > nLines ifTrue: [ from := 1 ]] - ifFalse: [index = 0 ifTrue: [^ 0]. - ^ from + index - 2]] repeat! Item was removed: - ----- Method: PopUpMenu>>startUpWithCaption: (in category 'basic control sequence') ----- - startUpWithCaption: captionOrNil - "Display the menu, slightly offset from the cursor, - so that a slight tweak is required to confirm any action." - self flag: #fix. "mt: Could we manage to open pop-up menus in Morphic without accessing self currentHand?" - - ^ self - startUpWithCaption: captionOrNil - at: (self currentHand ifNil: [Sensor]) cursorPoint! Item was removed: - ----- Method: PopUpMenu>>startUpWithCaption:at: (in category 'basic control sequence') ----- - startUpWithCaption: captionOrNil at: location - "Display the menu, with caption if supplied. Wait for the mouse button to go down, - then track the selection as long as the button is pressed. When the button is released, - answer the index of the current selection, or zero if the mouse is not released over - any menu item. Location specifies the desired topLeft of the menu body rectangle." - - ^ self startUpWithCaption: captionOrNil at: location allowKeyboard: Preferences menuKeyboardControl! Item was removed: - ----- Method: PopUpMenu>>startUpWithCaption:at:allowKeyboard: (in category 'basic control sequence') ----- - startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean - "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released, - Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard." - - ^ self - startUpWithCaption: captionOrNil - icon: nil - at: location - allowKeyboard: aBoolean! Item was removed: - ----- Method: PopUpMenu>>startUpWithCaption:icon: (in category 'basic control sequence') ----- - startUpWithCaption: captionOrNil icon: aForm - "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action." - - ^ self - startUpWithCaption: captionOrNil - icon: aForm - at: (self currentHand ifNil: [Sensor]) cursorPoint! Item was removed: - ----- Method: PopUpMenu>>startUpWithCaption:icon:at: (in category 'basic control sequence') ----- - startUpWithCaption: captionOrNil icon: aForm at: location - "Display the menu, with caption if supplied. Wait for the mouse button to go down, - then track the selection as long as the button is pressed. When the button is released, - answer the index of the current selection, or zero if the mouse is not released over - any menu item. Location specifies the desired topLeft of the menu body rectangle." - - ^ self - startUpWithCaption: captionOrNil - icon: aForm - at: location - allowKeyboard: Preferences menuKeyboardControl - ! Item was removed: - ----- Method: PopUpMenu>>startUpWithCaption:icon:at:allowKeyboard: (in category 'basic control sequence') ----- - startUpWithCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean - "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released, - Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard." - - | maxHeight | - (ProvideAnswerNotification signal: captionOrNil) ifNotNil: - [:answer | ^ selection := answer ifTrue: [1] ifFalse: [2]]. - - maxHeight := Display height*3//4. - self frameHeight > maxHeight ifTrue: - [^ self - startUpSegmented: maxHeight - withCaption: captionOrNil - at: location - allowKeyboard: aBoolean]. - - ^ Project uiManager startUpMenu: self withCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean! Item was removed: - ----- Method: PopUpMenu>>startUpWithoutKeyboard (in category 'basic control sequence') ----- - startUpWithoutKeyboard - "Display and make a selection from the receiver as long as the button is pressed. Answer the current selection. Do not allow keyboard input into the menu" - - ^ self - startUpWithCaption: nil - at: ((self currentHand ifNil: [Sensor]) cursorPoint) - allowKeyboard: false! Item was removed: - Model subclass: #ProcessBrowser - instanceVariableNames: 'selectedProcess selectedContext methodText processList processListIndex stackList stackListIndex stackDepth sourceMap selectedClass selectedSelector searchString autoUpdateProcess lastUpdate startedCPUWatcher' - classVariableNames: 'Browsers SuspendedProcesses WellKnownProcesses' - poolDictionaries: '' - category: 'Tools-Process Browser'! - - !ProcessBrowser commentStamp: '<historical>' prior: 0! - Change Set: ProcessBrowser - Date: 14 March 2000 - Author: Ned Konz - - email: ned at bike-nomad.com - - This is distributed under the Squeak License. - - Added 14 March: - CPUWatcher integration - automatically start and stop CPUWatcher - added CPUWatcher to process list menu - - Added 29 October: - MVC version - 2.8, 2.7 compatibility - rearranged menus - added pointer inspection and chasing - added suspend/resume - recognized more well-known processes - misc. bug fixes - - Added 26 October: highlight pc in source code - Added 27 October: added 'signal semaphore' - added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu - added 'find context', 'next context' to process list menu - added 'change priority' and 'debug' choices to process list menu - - 27 October mods by Bob Arning: - - alters process display in Ned's ProcessBrowser to - - show process priority - - drop 'a Process in' that appears on each line - - show in priority order - - prettier names for known processes - - fix to Utilities to forget update downloading process when it ends (1 less dead - process) - - correct stack dump for the active process - ! Item was removed: - ----- Method: ProcessBrowser class>>cleanUp (in category 'class initialization') ----- - cleanUp - "Remove terminated processes from my suspended list" - - self suspendedProcesses keys do: [:ea | - ea isTerminated ifTrue: [self suspendedProcesses removeKey: ea]]! Item was removed: - ----- Method: ProcessBrowser class>>debugProcess: (in category 'process control') ----- - debugProcess: aProcess - (aProcess isActiveProcess ifTrue: [Processor] ifFalse: [aProcess]) - debugWithTitle: 'Interrupted from the Process Browser' translated - full: true.! Item was removed: - ----- Method: ProcessBrowser class>>destroyProcess: (in category 'process control') ----- - destroyProcess: aProcess - - aProcess ifNil: [^ self]. - - self suspendedProcesses - removeKey: aProcess - ifAbsent: []. - aProcess destroy.! Item was removed: - ----- Method: ProcessBrowser class>>dumpTallyOnTranscript: (in category 'CPU utilization') ----- - dumpTallyOnTranscript: tally - "tally is from ProcessorScheduler>>tallyCPUUsageFor: - Dumps lines with percentage of time, hash of process, and a friendly name" - - tally sortedCounts do: [ :assoc | | procName | - procName := (self nameAndRulesFor: assoc value) first. - Transcript print: (((assoc key / tally size) * 100.0) roundTo: 1); - nextPutAll: '% '; - print: assoc value identityHash; space; - nextPutAll: procName; - cr. - ]. - Transcript flush.! Item was removed: - ----- Method: ProcessBrowser class>>initialize (in category 'class initialization') ----- - initialize - "ProcessBrowser initialize" - Browsers ifNil: [ Browsers := WeakSet new ]. - SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ]. - Smalltalk addToStartUpList: self. - Smalltalk addToShutDownList: self. - self registerInFlapsRegistry. - self registerWellKnownProcesses! Item was removed: - ----- Method: ProcessBrowser class>>isUIProcess: (in category 'process control') ----- - isUIProcess: aProcess - ^aProcess == Project uiProcess - ! Item was removed: - ----- Method: ProcessBrowser class>>nameAndRulesFor: (in category 'process control') ----- - nameAndRulesFor: aProcess - "Answer a nickname and two flags: allow-stop, and allow-debug" - ^ [aProcess caseOf: WellKnownProcesses - otherwise: - [(aProcess priority = Processor timingPriority - and: [aProcess suspendedContext receiver == Delay]) - ifTrue: [{'the timer interrupt watcher'. false. false}] - ifFalse: [{aProcess suspendedContext asString. true. true}]]] - ifError: [:err :rcvr | {aProcess suspendedContext asString. true. true}]! Item was removed: - ----- Method: ProcessBrowser class>>open (in category 'instance creation') ----- - open - ^ToolBuilder open: self new! Item was removed: - ----- Method: ProcessBrowser class>>postRecompileAction (in category 'recompilation') ----- - postRecompileAction - "Reinitialize the standard WellKnownProcesses. Each registration includes a couple of - block references that need to be freshened post recompile." - - WellKnownProcesses ifNotNil: - [:oldWKP| - self registerWellKnownProcesses. - "Attempt to preserve any user additions..." - WellKnownProcesses addAllLast: (oldWKP allButFirst: WellKnownProcesses size)]! Item was removed: - ----- Method: ProcessBrowser class>>prototypicalToolWindow (in category 'instance creation') ----- - prototypicalToolWindow - "Answer a window representing a prototypical instance of the receiver" - - ^ ToolBuilder build: self new! Item was removed: - ----- Method: ProcessBrowser class>>registerInFlapsRegistry (in category 'class initialization') ----- - registerInFlapsRegistry - "Register the receiver in the system's flaps registry" - self environment - at: #Flaps - ifPresent: [:cl | cl registerQuad: {#ProcessBrowser. #prototypicalToolWindow. 'Processes' translatedNoop. 'A Process Browser shows you all the running processes' translatedNoop} - forFlapNamed: 'Tools'.]! Item was removed: - ----- Method: ProcessBrowser class>>registerWellKnownProcess:label:allowStop:allowDebug: (in category 'process control') ----- - registerWellKnownProcess: aBlockForProcess label: nickname allowStop: allowStop allowDebug: allowDebug - "Add an entry to the registry of well known processes. aBlockForProcess - evaluates to a known process to be identified by nickname, and allowStop - and allowDebug are flags controlling allowable actions for this process - in the browser." - - WellKnownProcesses add: aBlockForProcess->[{nickname . allowStop . allowDebug}]! Item was removed: - ----- Method: ProcessBrowser class>>registerWellKnownProcesses (in category 'class initialization') ----- - registerWellKnownProcesses - "Associate each well-known process with a nickname and two flags: allow-stop, and allow-debug. - Additional processes may be added to this list as required" - - WellKnownProcesses := OrderedCollection new. - self registerWellKnownProcess: [] - label: 'no process' - allowStop: false - allowDebug: false. - self registerWellKnownProcess: [Smalltalk lowSpaceWatcherProcess] - label: 'the low space watcher' - allowStop: false - allowDebug: false. - self registerWellKnownProcess: [WeakArray runningFinalizationProcess] - label: 'the WeakArray finalization process' - allowStop: false - allowDebug: false. - self registerWellKnownProcess: [Processor activeProcess] - label: 'the UI process' - allowStop: true - allowDebug: true. - self registerWellKnownProcess: [Processor backgroundProcess] - label: 'the idle process' - allowStop: false - allowDebug: false. - self registerWellKnownProcess: [Sensor interruptWatcherProcess] - label: 'the user interrupt watcher' - allowStop: false - allowDebug: false. - self registerWellKnownProcess: [Sensor eventTicklerProcess] - label: 'the event tickler' - allowStop: false - allowDebug: false. - self registerWellKnownProcess: [Project uiProcess] - label: 'the inactive Morphic UI process' - allowStop: true - allowDebug: true. - " self registerWellKnownProcess: - [Smalltalk at: #SoundPlayer ifPresent: [:sp | sp playerProcess]] - label: 'the Sound Player' - allowStop: false - allowDebug: false." - self registerWellKnownProcess: - [ScheduledControllers ifNotNil: [ScheduledControllers activeControllerProcess]] - label: 'the inactive MVC controller process' - allowStop: false - allowDebug: true. - self registerWellKnownProcess: - [Smalltalk at: #CPUWatcher ifPresent: [:cw | cw currentWatcherProcess]] - label: 'the CPUWatcher' - allowStop: false - allowDebug: false - ! Item was removed: - ----- Method: ProcessBrowser class>>resumeProcess: (in category 'process control') ----- - resumeProcess: aProcess - | priority | - priority := self suspendedProcesses - removeKey: aProcess - ifAbsent: [aProcess priority]. - aProcess priority: priority. - aProcess suspendedContext ifNotNil: [ aProcess resume ] - ! Item was removed: - ----- Method: ProcessBrowser class>>setProcess:toPriority: (in category 'process control') ----- - setProcess: aProcess toPriority: priority - | oldPriority | - oldPriority := self suspendedProcesses at: aProcess ifAbsent: [ ]. - oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ]. - aProcess priority: priority. - ^oldPriority! Item was removed: - ----- Method: ProcessBrowser class>>shutDown (in category 'system startup') ----- - shutDown - Browsers do: [ :ea | ea isAutoUpdating ifTrue: [ ea pauseAutoUpdate ]]! Item was removed: - ----- Method: ProcessBrowser class>>startUp (in category 'system startup') ----- - startUp - Browsers - do: [:ea | ea isAutoUpdatingPaused - ifTrue: [ea initialize; startAutoUpdate] - ifFalse: [ea initialize]]! Item was removed: - ----- Method: ProcessBrowser class>>suspendProcess: (in category 'process control') ----- - suspendProcess: aProcess - | priority | - priority := aProcess priority. - self suspendedProcesses at: aProcess put: priority. - "Need to take the priority down below the caller's - so that it can keep control after signaling the Semaphore" - (aProcess suspendingList isKindOf: Semaphore) - ifTrue: [aProcess priority: Processor lowestPriority. - aProcess suspendingList signal]. - [aProcess suspend] - on: Error - do: [:ex | self suspendedProcesses removeKey: aProcess]. - aProcess priority: priority. - ! Item was removed: - ----- Method: ProcessBrowser class>>suspendedProcesses (in category 'process control') ----- - suspendedProcesses - "Answer a collection of processes that my instances have suspended. - This is so that they don't get garbage collected." - ^ SuspendedProcesses - ifNil: [SuspendedProcesses := IdentityDictionary new]! Item was removed: - ----- Method: ProcessBrowser class>>tallyCPUUsageFor: (in category 'CPU utilization') ----- - tallyCPUUsageFor: seconds - "Compute CPU usage using a 10-msec sample for the given number of seconds, - then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" - "ProcessBrowser tallyCPUUsageFor: 10" - ^self tallyCPUUsageFor: seconds every: 10! Item was removed: - ----- Method: ProcessBrowser class>>tallyCPUUsageFor:every: (in category 'CPU utilization') ----- - tallyCPUUsageFor: seconds every: msec - "Compute CPU usage using a msec millisecond sample for the given number of seconds, - then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" - "ProcessBrowser tallyCPUUsageFor: 10 every: 100" - - | promise | - promise := Processor tallyCPUUsageFor: seconds every: msec. - - [ | tally | - tally := promise value. - Smalltalk isMorphic - ifTrue: [ Project current addDeferredUIMessage: [ self dumpTallyOnTranscript: tally ] ] - ifFalse: [ [ Transcript open ] forkAt: Processor userSchedulingPriority. - [ (Delay forSeconds: 1) wait. - self dumpTallyOnTranscript: tally ] forkAt: Processor userSchedulingPriority.] - ] fork.! Item was removed: - ----- Method: ProcessBrowser class>>terminateProcess: (in category 'process control') ----- - terminateProcess: aProcess - - ^ self terminateProcess: aProcess aggressively: false! Item was removed: - ----- Method: ProcessBrowser class>>terminateProcess:aggressively: (in category 'process control') ----- - terminateProcess: aProcess aggressively: aggressive - - aProcess ifNil: [^ self]. - - self suspendedProcesses - removeKey: aProcess - ifAbsent: []. - aggressive - ifFalse: [aProcess terminate] - ifTrue: [aProcess terminateAggressively].! Item was removed: - ----- Method: ProcessBrowser class>>unload (in category 'class initialization') ----- - unload - "Unload the receiver from global registries" - - self environment at: #Flaps ifPresent: [:cl | - cl unregisterQuadsWithReceiver: self] ! Item was removed: - ----- Method: ProcessBrowser class>>unregisterWellKnownProcess: (in category 'process control') ----- - unregisterWellKnownProcess: aProcess - "Remove the first registry entry that matches aProcess. Use - with caution if more than one registry entry may match aProcess." - - "self unregisterWellKnownProcess: Smalltalk lowSpaceWatcherProcess" - - | entry | - entry := WellKnownProcesses - detect: [:e | e key value == aProcess] - ifNone: [^ self]. - WellKnownProcesses remove: entry! Item was removed: - ----- Method: ProcessBrowser class>>wasProcessSuspendedByProcessBrowser: (in category 'process control') ----- - wasProcessSuspendedByProcessBrowser: aProcess - ^self suspendedProcesses includesKey: aProcess! Item was removed: - ----- Method: ProcessBrowser>>browseContext (in category 'stack list') ----- - browseContext - ToolSet browseMethod: selectedContext home method! Item was removed: - ----- Method: ProcessBrowser>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "Create a pluggable version of me, answer a window" - | windowSpec listSpec textSpec | - windowSpec := builder pluggableWindowSpec new. - windowSpec model: self. - windowSpec label: 'Process Browser'. - windowSpec children: OrderedCollection new. - - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #processNameList; - getIndex: #processListIndex; - setIndex: #processListIndex:; - menu: #processListMenu:shifted:; - keyPress: #processListKey:from:; - frame: (0 @ 0 extent: 0.5 @ 0.5). - windowSpec children add: listSpec. - - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #stackNameList; - getIndex: #stackListIndex; - setIndex: #stackListIndex:; - menu: #stackListMenu:; - keyPress: #stackListKey:from:; - frame: (0.5 @ 0.0 extent: 0.5 @ 0.5). - windowSpec children add: listSpec. - - textSpec := builder pluggableTextSpec new. - textSpec - model: self; - getText: #selectedMethod; - setText: nil; - selection: nil; - menu: nil; - frame: (0 @ 0.5 corner: 1 @ 1). - windowSpec children add: textSpec. - - ^builder build: windowSpec! Item was removed: - ----- Method: ProcessBrowser>>changePriority (in category 'process actions') ----- - changePriority - | str newPriority nameAndRules | - nameAndRules := self nameAndRulesForSelectedProcess. - nameAndRules third ifFalse: [ - ^ self inform: ('Nope, won''t change priority of {1}' translated format: {nameAndRules first})]. - - str := Project uiManager - request: 'New priority' translated - initialAnswer: selectedProcess priority asString. - str isEmptyOrNil ifTrue: [^ self]. - - newPriority := str asNumber asInteger. - newPriority ifNil: [^ self]. - (newPriority < 1 - or: [newPriority > Processor highestPriority]) - ifTrue: [^ self inform: 'Bad priority' translated]. - - self class setProcess: selectedProcess toPriority: newPriority. - self updateProcessList.! Item was removed: - ----- Method: ProcessBrowser>>changeStackListTo: (in category 'stack list') ----- - changeStackListTo: aCollection - - stackList := aCollection. - self changed: #stackNameList. - self stackListIndex: 0! Item was removed: - ----- Method: ProcessBrowser>>chasePointers (in category 'process actions') ----- - chasePointers - | saved | - saved := selectedProcess. - [selectedProcess := nil. - (Smalltalk includesKey: #PointerFinder) - ifTrue: [PointerFinder on: saved] - ifFalse: [self inspectPointers]] - ensure: [selectedProcess := saved]! Item was removed: - ----- Method: ProcessBrowser>>copyProcessStackToClipboard (in category 'process list') ----- - copyProcessStackToClipboard - | stackStream startContext | - stackStream := WriteStream on: (String new: 256). - startContext := selectedProcess == Processor activeProcess - ifTrue: [thisContext] - ifFalse: [selectedProcess suspendedContext]. - startContext findContextSuchThat: - [:context| - stackStream print: context; cr. - false]. - Clipboard clipboardText: stackStream contents! Item was removed: - ----- Method: ProcessBrowser>>debugProcess (in category 'process actions') ----- - debugProcess - | nameAndRules | - nameAndRules := self nameAndRulesForSelectedProcess. - nameAndRules third - ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first. - ^ self]. - self class debugProcess: selectedProcess.! Item was removed: - ----- Method: ProcessBrowser>>destroyProcess (in category 'process actions') ----- - destroyProcess - - | nameAndRules | - nameAndRules := self nameAndRulesForSelectedProcess. - nameAndRules second ifFalse: [ - ^ self inform: ('Nope, won''t destroy {1}' translated format: {nameAndRules first})]. - self class destroyProcess: selectedProcess. - self updateProcessList.! Item was removed: - ----- Method: ProcessBrowser>>exploreContext (in category 'stack list') ----- - exploreContext - selectedContext explore! Item was removed: - ----- Method: ProcessBrowser>>exploreProcess (in category 'process list') ----- - exploreProcess - selectedProcess explore! Item was removed: - ----- Method: ProcessBrowser>>exploreReceiver (in category 'stack list') ----- - exploreReceiver - selectedContext receiver explore! Item was removed: - ----- Method: ProcessBrowser>>findContext (in category 'process list') ----- - findContext - | initialProcessIndex initialStackIndex found | - initialProcessIndex := self processListIndex. - initialStackIndex := self stackListIndex. - searchString := Project uiManager - request: 'Enter a string to search for in the process stack lists' translated - initialAnswer: searchString. - searchString isEmpty - ifTrue: [^ false]. - self processListIndex: 1. - self stackListIndex: 1. - found := self nextContext. - found - ifFalse: [self processListIndex: initialProcessIndex. - self stackListIndex: initialStackIndex]. - ^ found! Item was removed: - ----- Method: ProcessBrowser>>fullStack (in category 'stack list') ----- - fullStack - stackDepth := SmallInteger maxVal. - self updateStackList! Item was removed: - ----- Method: ProcessBrowser>>hasView (in category 'views') ----- - hasView - ^self dependents isEmptyOrNil not! Item was removed: - ----- Method: ProcessBrowser>>initialize (in category 'initialize-release') ----- - initialize - methodText := ''.. - stackDepth := 20. - stackListIndex := 0. - searchString := ''. - lastUpdate := 0. - startedCPUWatcher := CPUWatcher cpuWatcherEnabled and: [ self startCPUWatcher ]. - self updateProcessList; processListIndex: 1. - Browsers add: self! Item was removed: - ----- Method: ProcessBrowser>>inspectContext (in category 'stack list') ----- - inspectContext - selectedContext inspect! Item was removed: - ----- Method: ProcessBrowser>>inspectPointers (in category 'process actions') ----- - inspectPointers - | tc pointers | - tc := thisContext. - pointers := PointerFinder - pointersTo: selectedProcess - except: { - self processList. - tc. - self}. - pointers isEmpty ifTrue: [^ self]. - ToolSet - inspect: pointers - label: 'Objects pointing to ' , selectedProcess browserPrintString! Item was removed: - ----- Method: ProcessBrowser>>inspectProcess (in category 'process list') ----- - inspectProcess - selectedProcess inspect! Item was removed: - ----- Method: ProcessBrowser>>inspectReceiver (in category 'stack list') ----- - inspectReceiver - selectedContext receiver inspect! Item was removed: - ----- Method: ProcessBrowser>>isAutoUpdating (in category 'updating') ----- - isAutoUpdating - ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended not ]! Item was removed: - ----- Method: ProcessBrowser>>isAutoUpdatingPaused (in category 'updating') ----- - isAutoUpdatingPaused - ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]! Item was removed: - ----- Method: ProcessBrowser>>messageTally (in category 'stack list') ----- - messageTally - | secString secs | - secString := Project uiManager request: 'Profile for how many seconds?' translated initialAnswer: '4'. - secString isEmptyOrNil ifTrue: [^ self]. - secs := secString asNumber asInteger. - (secs isNil or: [secs isZero]) - ifTrue: [^ self]. - [ TimeProfileBrowser spyOnProcess: selectedProcess forMilliseconds: secs * 1000 ] forkAt: selectedProcess priority + 1.! Item was removed: - ----- Method: ProcessBrowser>>moreStack (in category 'stack list') ----- - moreStack - stackDepth := stackDepth + stackDepth. - self updateStackList! Item was removed: - ----- Method: ProcessBrowser>>nameAndRulesFor: (in category 'process actions') ----- - nameAndRulesFor: aProcess - "Answer a nickname and two flags: allow-stop, and allow-debug" - aProcess == autoUpdateProcess ifTrue: [ ^{'my auto-update process'. true. true} ]. - ^self class nameAndRulesFor: aProcess - ! Item was removed: - ----- Method: ProcessBrowser>>nameAndRulesForSelectedProcess (in category 'process actions') ----- - nameAndRulesForSelectedProcess - "Answer a nickname and two flags: allow-stop, and allow-debug" - ^self nameAndRulesFor: selectedProcess! Item was removed: - ----- Method: ProcessBrowser>>nextContext (in category 'process list') ----- - nextContext - | initialProcessIndex initialStackIndex | - searchString isEmpty ifTrue: [ ^false ]. - initialProcessIndex := self processListIndex. - initialStackIndex := self stackListIndex. - initialProcessIndex - to: self processList size - do: [:pi | self processListIndex: pi. - self stackNameList - withIndexDo: [:name :si | (pi ~= initialProcessIndex - or: [si > initialStackIndex]) - ifTrue: [(name includesSubstring: searchString) - ifTrue: [self stackListIndex: si. - ^true]]]]. - self processListIndex: initialProcessIndex. - self stackListIndex: initialStackIndex. - ^ false! Item was removed: - ----- Method: ProcessBrowser>>notify:at:in: (in category 'process list') ----- - notify: errorString at: location in: aStream - "A syntax error happened when I was trying to highlight my pc. - Raise a signal so that it can be ignored." - Warning signal: 'syntax error'! Item was removed: - ----- Method: ProcessBrowser>>pauseAutoUpdate (in category 'updating') ----- - pauseAutoUpdate - self isAutoUpdating - ifTrue: [ autoUpdateProcess suspend ]. - self updateProcessList! Item was removed: - ----- Method: ProcessBrowser>>pcRange (in category 'stack list') ----- - pcRange - "Answer the indices in the source code for the method corresponding to - the selected context's program counter value." - (selectedContext isNil or: [methodText isEmptyOrNil]) ifTrue: - [^ 1 to: 0]. - ^selectedContext debuggerMap - rangeForPC: (selectedContext pc ifNil: [selectedContext method endPC]) - in: selectedContext method - contextIsActiveContext: stackListIndex = 1! Item was removed: - ----- Method: ProcessBrowser>>prettyNameForProcess: (in category 'process list') ----- - prettyNameForProcess: aProcess - | nameAndRules | - aProcess ifNil: [ ^'<nil>' ]. - nameAndRules := self nameAndRulesFor: aProcess. - ^ aProcess browserPrintStringWith: nameAndRules first! Item was removed: - ----- Method: ProcessBrowser>>processList (in category 'accessing') ----- - processList - ^ processList! Item was removed: - ----- Method: ProcessBrowser>>processListIndex (in category 'accessing') ----- - processListIndex - ^ processListIndex! Item was removed: - ----- Method: ProcessBrowser>>processListIndex: (in category 'accessing') ----- - processListIndex: index - processListIndex := index. - selectedProcess := processList - at: index - ifAbsent: []. - self updateStackList. - self changed: #processListIndex.! Item was removed: - ----- Method: ProcessBrowser>>processListKey:from: (in category 'process list') ----- - processListKey: aKey from: aView - - aKey - caseOf: { - [$f] -> [^ self findContext]. - [$g] -> [^ self nextContext]. - [$a] -> [^ self toggleAutoUpdate]. - [$u] -> [^ self updateProcessList] } - otherwise: []. - selectedProcess ifNil: [^ self changed: #flash]. - ^ aKey - caseOf: { - [$i] -> [self inspectProcess]. - [$I] -> [self exploreProcess]. - [$c] -> [self chasePointers]. - [$P] -> [self inspectPointers]. - [$t] -> [self terminateProcess]. - [$T] -> [self terminateProcessAggressively]. - [$r] -> [self resumeProcess]. - [$s] -> [self suspendProcess]. - [$d] -> [self debugProcess]. - [$p] -> [self changePriority]. - [$m] -> [self messageTally]. - [$S] -> [self signalSemaphore]. - [$k] -> [self fullStack]} - otherwise: [self arrowKey: aKey from: aView]! Item was removed: - ----- Method: ProcessBrowser>>processListMenu:shifted: (in category 'process list') ----- - processListMenu: menu shifted: shifted - - selectedProcess ifNotNil: - [:process| - [:name :allowStop :allowDebug| - menu addList: #(('inspect (i)' inspectProcess) ('explore (I)' exploreProcess) ('inspect Pointers (P)' inspectPointers)). - (Smalltalk includesKey: #PointerFinder) ifTrue: - [menu add: 'chase pointers (c)' translated action: #chasePointers]. - menu addLine. - allowStop ifTrue: - [menu add: 'terminate (t)' translated action: #terminateProcess. - menu add: 'terminate aggressively (T)' translated action: #terminateProcessAggressively. - shifted ifTrue: - [menu - add: 'destroy' translated action: #destroyProcess; - balloonTextForLastItem: (Process firstCommentAt: #destroy)]. - process isSuspended - ifTrue: [menu add: 'resume (r)' translated action: #resumeProcess] - ifFalse: [menu add: 'suspend (s)' translated action: #suspendProcess]]. - allowDebug ifTrue: - [menu addList: #(('change priority (p)' changePriority) ('debug (d)' debugProcess))]. - menu add: 'profile messages (m)' action: #messageTally. - (process suspendingList isKindOf: Semaphore) ifTrue: - [menu add: 'signal Semaphore (S)' translated action: #signalSemaphore]. - menu addList: #(('full stack (k)' fullStack) ('copy stack to clipboard' copyProcessStackToClipboard)). - menu addLine] valueWithArguments: (self nameAndRulesFor: process)]. - - menu - addList: #(#('find context... (f)' findContext) #('find again (g)' nextContext)); - addLine; - add: (self isAutoUpdating - ifTrue: ['turn off auto-update (a)' translated] - ifFalse: ['turn on auto-update (a)' translated]) - action: #toggleAutoUpdate; - add: 'update list (u)' translated action: #updateProcessList. - - (Smalltalk at: #CPUWatcher ifAbsent: []) ifNotNil: - [:pw| - menu addLine. - pw isMonitoring - ifTrue: [menu add: 'stop CPUWatcher' translated action: #stopCPUWatcher] - ifFalse: [menu add: 'start CPUWatcher' translated action: #startCPUWatcher]]. - - ^menu! Item was removed: - ----- Method: ProcessBrowser>>processNameList (in category 'process list') ----- - processNameList - "since processList is a WeakArray, we have to strengthen the result" - | pw tally | - pw := Smalltalk at: #CPUWatcher ifAbsent: [ ]. - tally := pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ]. - ^ (processList asOrderedCollection - copyWithout: nil) - collect: [:each | | percent | - percent := tally - ifNotNil: [ ((((tally occurrencesOf: each) * 100.0 / tally size) roundTo: 1) - asString padded: #left to: 2 with: $ ), '% ' ] - ifNil: [ '' ]. - percent, (self prettyNameForProcess: each) - ] ! Item was removed: - ----- Method: ProcessBrowser>>resumeProcess (in category 'process actions') ----- - resumeProcess - self class resumeProcess: selectedProcess. - self updateProcessList! Item was removed: - ----- Method: ProcessBrowser>>selectedClass (in category 'accessing') ----- - selectedClass - "Answer the class in which the currently selected context's method was - found." - ^ selectedClass - ifNil: [ - selectedContext ifNil: [^ nil]. - selectedClass := selectedContext receiver - ifNil: [selectedSelector := selectedContext method selector. - selectedContext method methodClass] - ifNotNil: [selectedContext methodClass]]! Item was removed: - ----- Method: ProcessBrowser>>selectedMethod (in category 'accessing') ----- - selectedMethod - ^ methodText ifNil: [methodText := selectedContext - ifNil: [''] - ifNotNil: [| pcRange | - methodText := [ selectedContext sourceCode ] - ifError: [ :err :rcvr | 'error getting method text' ]. - pcRange := self pcRange. - methodText asText - addAttribute: TextColor red - from: pcRange first - to: pcRange last; - - addAttribute: TextEmphasis bold - from: pcRange first - to: pcRange last]]! Item was removed: - ----- Method: ProcessBrowser>>selectedProcess (in category 'accessing') ----- - selectedProcess - - self processListIndex = 0 ifTrue: [^ nil]. - ^ self processList at: self processListIndex! Item was removed: - ----- Method: ProcessBrowser>>selectedSelector (in category 'accessing') ----- - selectedSelector - "Answer the class in which the currently selected context's method was - found." - ^ selectedSelector - ifNil: [selectedSelector := selectedContext receiver - ifNil: [selectedClass := selectedContext method methodClass - selectedContext method selector] - ifNotNil: [selectedContext selector]]! Item was removed: - ----- Method: ProcessBrowser>>setUpdateCallbackAfter: (in category 'updating') ----- - setUpdateCallbackAfter: seconds - - [(Delay forSeconds: seconds) wait. - Project current addDeferredUIMessage: [self updateProcessList]] fork! Item was removed: - ----- Method: ProcessBrowser>>signalSemaphore (in category 'process actions') ----- - signalSemaphore - (selectedProcess suspendingList isKindOf: Semaphore) - ifFalse: [^ self]. - [selectedProcess suspendingList signal] fork. - (Delay forMilliseconds: 300) wait. - "Hate to make the UI wait, but it's convenient..." - self updateProcessList! Item was removed: - ----- Method: ProcessBrowser>>stackList (in category 'accessing') ----- - stackList - ^ stackList! Item was removed: - ----- Method: ProcessBrowser>>stackListIndex (in category 'accessing') ----- - stackListIndex - ^ stackListIndex! Item was removed: - ----- Method: ProcessBrowser>>stackListIndex: (in category 'accessing') ----- - stackListIndex: index - stackListIndex := index. - selectedContext := (stackList notNil - and: [index > 0]) ifTrue: - [stackList at: index ifAbsent: []]. - selectedClass := nil. - selectedSelector := nil. - methodText := nil. - self changed: #stackListIndex. - self changed: #selectedMethod! Item was removed: - ----- Method: ProcessBrowser>>stackListKey:from: (in category 'views') ----- - stackListKey: aKey from: aView - - selectedContext ifNil: [^ self changed: #flash]. - ^ aKey - caseOf: { - [$c] -> [self inspectContext]. - [$C] -> [self exploreContext]. - [$i] -> [self inspectReceiver]. - [$I] -> [self exploreReceiver]. - [$b] -> [self browseContext]} - otherwise: [self arrowKey: aKey from: aView]! Item was removed: - ----- Method: ProcessBrowser>>stackListMenu: (in category 'stack list') ----- - stackListMenu: aMenu - selectedContext ifNil: [^aMenu]. - ^aMenu - labels: 'inspect context (c) - explore context (C) - inspect receiver (i) - explore receiver (I) - browse (b) - more stack' - lines: #(2 4 5) - selections: #(#inspectContext #exploreContext #inspectReceiver #exploreReceiver #browseContext moreStack)! Item was removed: - ----- Method: ProcessBrowser>>stackNameList (in category 'stack list') ----- - stackNameList - ^ stackList - ifNil: [#()] - ifNotNil: [stackList - collect: [:each | each asString]]! Item was removed: - ----- Method: ProcessBrowser>>startAutoUpdate (in category 'updating') ----- - startAutoUpdate - self isAutoUpdatingPaused - ifTrue: [^ autoUpdateProcess resume]. - - self isAutoUpdating ifFalse: - [| project | - project := Project current. - autoUpdateProcess := - [[[self hasView] whileTrue: - [2 seconds wait. - project addDeferredUIMessage: [self updateProcessList]]. - autoUpdateProcess := nil] - ensure: [self removeActionsForEvent: #aboutToEnterWorld]] fork. - - "Do not update process browsers from inactive projects. Otherwise, an auto-updating process browser from a Morphic project would raise periodic errors after entering an MVC project, or an auto-updating process browser from a MVC project would cause spooky screen updates after entering a Morphic project." - self flag: #startStepping:. "A better solution strategy would use something like StepMessages for MVC, which however do not exist as of today." - project world - when: #aboutToLeaveWorld send: #pauseAutoUpdate to: self; - when: #aboutToEnterWorld send: #startAutoUpdate to: self]. - - self updateProcessList.! Item was removed: - ----- Method: ProcessBrowser>>startCPUWatcher (in category 'initialize-release') ----- - startCPUWatcher - "Answers whether I started the CPUWatcher" - - | pw | - pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ]. - pw ifNotNil: [ - pw isMonitoring ifFalse: [ - pw startMonitoringPeriod: 5 rate: 100 threshold: 0.85. - self setUpdateCallbackAfter: 7. - ^true - ] - ]. - ^false - ! Item was removed: - ----- Method: ProcessBrowser>>stopAutoUpdate (in category 'updating') ----- - stopAutoUpdate - autoUpdateProcess ifNotNil: [ - autoUpdateProcess terminate. - autoUpdateProcess := nil]. - self updateProcessList! Item was removed: - ----- Method: ProcessBrowser>>stopCPUWatcher (in category 'initialize-release') ----- - stopCPUWatcher - | pw | - pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ]. - pw ifNotNil: [ - pw stopMonitoring. - self updateProcessList. - startedCPUWatcher := false. "so a manual restart won't be killed later" - ] - ! Item was removed: - ----- Method: ProcessBrowser>>suspendProcess (in category 'process actions') ----- - suspendProcess - | nameAndRules | - selectedProcess isSuspended ifTrue: - [^self]. - nameAndRules := self nameAndRulesForSelectedProcess. - nameAndRules second ifFalse: - [self inform: 'Nope, won''t suspend ' , nameAndRules first. - ^self]. - selectedProcess == Project current uiProcess ifTrue: - [Project current spawnNewProcessIfThisIsUI: selectedProcess. - WorldState addDeferredUIMessage: [self updateProcessList]]. - self class suspendProcess: selectedProcess. - self updateProcessList! Item was removed: - ----- Method: ProcessBrowser>>terminateProcess (in category 'process actions') ----- - terminateProcess - - ^ self terminateProcess: false! Item was removed: - ----- Method: ProcessBrowser>>terminateProcess: (in category 'process actions') ----- - terminateProcess: aggressive - - | nameAndRules | - nameAndRules := self nameAndRulesForSelectedProcess. - nameAndRules second ifFalse: [ - ^ self inform: ('Nope, won''t terminate {1}' translated format: {nameAndRules first})]. - self class terminateProcess: selectedProcess aggressively: aggressive. - self updateProcessList.! Item was removed: - ----- Method: ProcessBrowser>>terminateProcessAggressively (in category 'process actions') ----- - terminateProcessAggressively - - ^ self terminateProcess: true! Item was removed: - ----- Method: ProcessBrowser>>text (in category 'accessing') ----- - text - ^methodText! Item was removed: - ----- Method: ProcessBrowser>>toggleAutoUpdate (in category 'updating') ----- - toggleAutoUpdate - self isAutoUpdating - ifTrue: [ self stopAutoUpdate ] - ifFalse: [ self startAutoUpdate ]. - ! Item was removed: - ----- Method: ProcessBrowser>>updateProcessList (in category 'process list') ----- - updateProcessList - | oldSelectedProcess newIndex now | - now := Time millisecondClockValue. - now - lastUpdate < 500 - ifTrue: [^ self]. - "Don't update too fast" - lastUpdate := now. - oldSelectedProcess := selectedProcess. - processList := selectedProcess := selectedSelector := nil. - Smalltalk garbageCollectMost. - "lose defunct processes" - - processList := Process allSubInstances - reject: [:each | each isTerminated]. - processList := processList - sorted: [:a :b | a priority >= b priority]. - processList := WeakArray withAll: processList. - newIndex := processList indexOf: oldSelectedProcess. - self changed: #processNameList. - self processListIndex: newIndex! Item was removed: - ----- Method: ProcessBrowser>>updateStackList (in category 'stack list') ----- - updateStackList - self updateStackList: stackDepth! Item was removed: - ----- Method: ProcessBrowser>>updateStackList: (in category 'stack list') ----- - updateStackList: depth - | suspendedContext oldHighlight | - selectedProcess - ifNil: [^ self changeStackListTo: nil]. - (stackList notNil and: [ stackListIndex > 0 ]) - ifTrue: [oldHighlight := stackList at: stackListIndex]. - selectedProcess == Processor activeProcess - ifTrue: [self - changeStackListTo: (thisContext stackOfSize: depth)] - ifFalse: [suspendedContext := selectedProcess suspendedContext. - suspendedContext - ifNil: [self changeStackListTo: nil] - ifNotNil: [self - changeStackListTo: (suspendedContext stackOfSize: depth)]]. - self - stackListIndex: (stackList - ifNil: [0] - ifNotNil: [stackList indexOf: oldHighlight])! Item was removed: - ----- Method: ProcessBrowser>>wasProcessSuspendedByProcessBrowser: (in category 'process actions') ----- - wasProcessSuspendedByProcessBrowser: aProcess - ^self class suspendedProcesses includesKey: aProcess! Item was removed: - ----- Method: ProcessBrowser>>windowIsClosing (in category 'initialize-release') ----- - windowIsClosing - startedCPUWatcher ifTrue: [ CPUWatcher stopMonitoring ]! Item was removed: - ----- Method: PseudoClass>>toolIcon (in category '*Tools-icons') ----- - toolIcon - "For polymorphy with behaviors" - ^ self realClass ifNil: [#blank] ifNotNil: [:real | real toolIcon]! Item was removed: - ----- Method: PseudoClass>>toolIconSelector: (in category '*Tools-icons') ----- - toolIconSelector: aSymbol - "For polymorphy with behaviors" - ^ self realClass ifNil: [#blank] ifNotNil: [:real | real toolIconSelector: aSymbol]! Item was removed: - MessageSet subclass: #RecentMessageSet - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !RecentMessageSet commentStamp: 'sw 8/1/2002 17:40' prior: 0! - RecentMessageSet is a message set that shows the most recently-submitted methods, in chronological order.! Item was removed: - ----- Method: RecentMessageSet>>addExtraShiftedItemsTo: (in category 'message list') ----- - addExtraShiftedItemsTo: aMenu - "The shifted selector-list menu is being built. Overridden here to defeat the presence of the items that add or change order, since RecentMessageSet defines methods & order explicitly based on external criteria" - - aMenu add: 'set size of recent history...' target: RecentMessages action: #setRecentHistorySize! Item was removed: - ----- Method: RecentMessageSet>>contents:notifying: (in category 'contents') ----- - contents: c notifying: n - | result | - result := super contents: c notifying: n. - result == true ifTrue: - [self reformulateList]. - ^ result! Item was removed: - ----- Method: RecentMessageSet>>formattedLabel:forSelector:inClass: (in category 'message list') ----- - formattedLabel: aString forSelector: aSymbol inClass: aClass - "Overridden to account for outdated MethodReference after class renames." - - self flag: #fix. "mt: We might want to fix RecentMessages to instead. Other tools (or features) might depend on it, too." - ^ aClass - ifNil: [aString asText] - ifNotNil: [super formattedLabel: aString forSelector: aSymbol inClass: aClass] - ! Item was removed: - ----- Method: RecentMessageSet>>growable (in category 'update') ----- - growable - "Answer whether the receiver can be changed by manual additions & deletions" - - ^ false! Item was removed: - ----- Method: RecentMessageSet>>initializeMessageList: (in category 'private') ----- - initializeMessageList: anArray - "Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses. - Do /not/ replace the elements of anArray if they are already MethodReferences, so as to allow users to construct richer systems, such as differencers between existing and edited versions of code." - messageList := OrderedCollection new. - anArray do: - [:each | each isMethodReference - ifTrue: [messageList addLast: each] - ifFalse: - [ MessageSet - parse: each - toClassAndSelector: - [ : class : sel | class ifNotNil: [ messageList addLast: (MethodReference class: class selector: sel) ] ] ] ]. - messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1]. - contents := String empty! Item was removed: - ----- Method: RecentMessageSet>>messageHelpForMethod: (in category 'message list') ----- - messageHelpForMethod: aMethod - "Overridden to account for outdated MethodReference after class renames." - - self flag: #fix. "mt: We might want to fix RecentMessages to instead. Other tools (or features) might depend on it, too." - ^ aMethod ifNotNil: [super messageHelpForMethod: aMethod]! Item was removed: - ----- Method: RecentMessageSet>>messageListMenuForRecentSubmission: (in category 'message functions') ----- - messageListMenuForRecentSubmission: aMenu - <messageListMenuShifted: false> - aMenu addList:#( - ('remove from RecentSubmissions' removeFromRecentSubmissions)). - ^ aMenu! Item was removed: - ----- Method: RecentMessageSet>>reformulateList (in category 'update') ----- - reformulateList - "Reformulate the receiver's list. Exclude methods now deleted" - - | currentSelection | - messageListIndex > 0 ifTrue: - [currentSelection := messageList at: messageListIndex]. - self initializeMessageList: (RecentMessages default methodReferences select: [:mr| mr isValid]). - currentSelection ifNotNil: - [messageListIndex := messageList indexOf: currentSelection ifAbsent: [1]]. - self - changed: #messageList; - changed: #messageListIndex! Item was removed: - ----- Method: RecentMessageSet>>removeFromRecentSubmissions (in category 'message functions') ----- - removeFromRecentSubmissions - "Remove the currently-selected method from the RecentMessages list" - - | aClass methodSym | - ((aClass := self selectedClassOrMetaClass) notNil and: [(methodSym := self selectedMessageName) notNil]) - ifTrue: - [RecentMessages default purgeFromRecentSubmissions: (MethodReference class: aClass selector: methodSym). - self reformulateList]! Item was removed: - ----- Method: RecentMessageSet>>setRecentHistorySize (in category 'message list') ----- - setRecentHistorySize - "Let the user specify the recent history size" - - | aReply aNumber | - aReply := UIManager default request: 'How many recent methods - should be maintained?' initialAnswer: RecentMessages numberOfRecentSubmissionsToStore asString. - aReply isEmptyOrNil ifFalse: - [aNumber := aReply asNumber rounded. - (aNumber > 1 and: [aNumber <= 1000]) - ifTrue: - [RecentMessages numberOfRecentSubmissionsToStore: aNumber. - self inform: 'Okay, ', aNumber asString, ' is the new size of the recent method history'] - ifFalse: - [self inform: 'Sorry, must be a number between 2 & 1000']]! Item was removed: - ----- Method: RecentMessageSet>>updateListsAndCodeIn: (in category 'update') ----- - updateListsAndCodeIn: aWindow - self canDiscardEdits ifFalse: [^self]. - RecentMessages default isEmpty ifTrue: [^self]. - (messageList isEmpty - or: [RecentMessages default mostRecent = messageList first and: [RecentMessages default mostRecent isValid]]) - ifTrue: [self updateCodePaneIfNeeded] - ifFalse: [self reformulateList]! Item was removed: - Object subclass: #SavedMultiWindowState - instanceVariableNames: 'models modelStates modelDependents currentModelIndex prototype' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Base'! - - !SavedMultiWindowState commentStamp: 'eem 6/30/2010 15:45' prior: 0! - A SavedMultiWindowState is a collection of states of inactive windows for a multi-window tool ui where one can select between multiple copies of a tool sharing a single system window, each tol having its own state. It manages switching between windows, swapping unaccepted edit state (e.g. in text views) as it does so. - - Instance Variables - currentModelIndex: <Integer> - modelDependents: <IdentitySet> - modelStates: <OrderedCollection of: (Array - with: modelState <Object> - with: unacceptedEditStates <WeakIdentityKeyDictionary>) > - models: <OrderedCollection of: Model> - - currentModelIndex - - index into models and modelStates of current window selection - - modelDependents - - set of all dependents - - modelStates - - the pairs of model-specific selection state and widget-specfic unaccepted edit state for each unselected/inactive window - - models - - the models for each window - ! Item was removed: - ----- Method: SavedMultiWindowState class>>on: (in category 'instance creation') ----- - on: aModel - ^self new on: aModel! Item was removed: - ----- Method: SavedMultiWindowState>>addNewWindow (in category 'operations') ----- - addNewWindow - self addWindow: prototype shallowCopy! Item was removed: - ----- Method: SavedMultiWindowState>>addWindow: (in category 'operations') ----- - addWindow: aModel - aModel multiWindowState: self. - self assert: models size = modelStates size. - models := models - copyReplaceFrom: currentModelIndex + 1 - to: currentModelIndex - with: (Array with: aModel). - modelStates := modelStates - copyReplaceFrom: currentModelIndex + 1 - to: currentModelIndex - with: (Array with: self emptyEditState). - self assert: models size = modelStates size. - self selectWindowIndex: (currentModelIndex = 0 ifTrue: [currentModelIndex := 1] ifFalse: [currentModelIndex + 1]). - self assert: models size = modelStates size. - 1 to: models size do: - [:idx| - self assert: (idx = currentModelIndex - or: [(modelStates at: idx) isArray and: [(modelStates at: idx) size = 2]])]! Item was removed: - ----- Method: SavedMultiWindowState>>copyWindow (in category 'operations') ----- - copyWindow - self addWindow: (models at: currentModelIndex) copy breakDependents! Item was removed: - ----- Method: SavedMultiWindowState>>currentModelIndex (in category 'accessing') ----- - currentModelIndex - ^currentModelIndex! Item was removed: - ----- Method: SavedMultiWindowState>>editState (in category 'selecting') ----- - editState - | textState | - textState := WeakIdentityKeyDictionary new. - modelDependents do: - [:dep| - dep canHaveUnacceptedEdits ifTrue: - [textState at: dep put: dep unacceptedEditState]]. - ^textState! Item was removed: - ----- Method: SavedMultiWindowState>>emptyEditState (in category 'accessing') ----- - emptyEditState - ^#(nil ())! Item was removed: - ----- Method: SavedMultiWindowState>>initialize (in category 'initialize-release') ----- - initialize - models := OrderedCollection new. - modelStates := OrderedCollection new. - modelDependents := IdentitySet new. - currentModelIndex := 0! Item was removed: - ----- Method: SavedMultiWindowState>>models (in category 'accessing') ----- - models - ^models! Item was removed: - ----- Method: SavedMultiWindowState>>okToClose (in category 'testing') ----- - okToClose - "Answer if the unaccepted edit states are void. If they are not then - offer to select a window with non-empty unaccepted edit state." - - modelStates withIndexDo: - [:savedState :index| - savedState ifNotNil: - [(savedState last anySatisfy: [:editState| editState notNil]) ifTrue: - [(PopUpMenu - confirm: 'One or more windows have unsaved changes.' - trueChoice: 'Close Anyway' - falseChoice: 'Select Unsaved') ifTrue: [^true]. - self selectWindowIndex: index. - ^false]]]. - ^true! Item was removed: - ----- Method: SavedMultiWindowState>>on: (in category 'initialize-release') ----- - on: aModel - prototype := aModel shallowCopy. - self addWindow: aModel! Item was removed: - ----- Method: SavedMultiWindowState>>prototype (in category 'accessing') ----- - prototype - ^prototype! Item was removed: - ----- Method: SavedMultiWindowState>>removeCurrentWindow (in category 'operations') ----- - removeCurrentWindow - "Remove the current pane." - | deletedIndex | - self assert: models size > 1. - self assert: models size = modelStates size. - (models at: currentModelIndex) okToChange ifFalse: - [^self]. - deletedIndex := currentModelIndex. - self selectWindowIndex: (currentModelIndex = 1 - ifTrue: [currentModelIndex + 1] - ifFalse: [currentModelIndex - 1]). - models := models copyWithoutIndex: deletedIndex. - modelStates := modelStates copyWithoutIndex: deletedIndex. - currentModelIndex > deletedIndex ifTrue: - [currentModelIndex := currentModelIndex - 1]. - (models at: currentModelIndex) changed: #relabel! Item was removed: - ----- Method: SavedMultiWindowState>>restoreEditState: (in category 'selecting') ----- - restoreEditState: aWeakDictionary - aWeakDictionary keysAndValuesDo: - [:depOrNil :unacceptedEditState| - depOrNil ifNotNil: - [depOrNil unacceptedEditState: unacceptedEditState]]! Item was removed: - ----- Method: SavedMultiWindowState>>selectWindowIndex: (in category 'selecting') ----- - selectWindowIndex: index - | currentModel newModel newModelState | - index = currentModelIndex ifTrue: [^self]. - - currentModel := models at: currentModelIndex. - newModel := models at: index. - modelDependents addAll: currentModel dependents. - modelStates at: currentModelIndex put: { currentModel saveMultiWindowState. self editState }. - "the become makes things confusing. currentModel will end up being newModel and vice verce" - models swap: currentModelIndex with: index. - currentModel become: newModel. - currentModel := models at: currentModelIndex. - newModel := models at: index. - newModel myDependents: (DependentsArray withAll: modelDependents asArray). - currentModel myDependents: nil. - "Change currentModelIndex before restoreMultiWIndowState: so label index is shown correctly" - currentModelIndex := index. - newModelState := modelStates at: index. - newModelState first ifNotNil: "emptyState has nil for savedModelState. Don;t restore state for a new window" - [:savedModelState| newModel restoreMultiWindowState: savedModelState]. - self restoreEditState: newModelState last. - modelStates at: index put: nil. - newModel changed: #relabel! Item was removed: - ----- Method: SavedMultiWindowState>>selectWindowsMenu (in category 'operations') ----- - selectWindowsMenu - | menu currentItem | - menu := MenuMorph new defaultTarget: self. - models withIndexDo: - [:model :index| | modelLabel | - modelLabel := index = currentModelIndex - ifTrue: [model multiWindowName] - ifFalse: [model multiWindowNameForState: (modelStates at: index) first]. - models size > 1 ifTrue: - [modelLabel := index printString, '. ', modelLabel]. - menu - add: (index = currentModelIndex - ifTrue: [Text string: modelLabel attribute: TextEmphasis bold] - ifFalse: - [((modelStates at: index) last anySatisfy: [:editState| editState notNil]) - ifTrue: [Text string: modelLabel attribute: TextColor red] - ifFalse: [modelLabel]]) - target: self - selector: #selectWindowIndex: - argument: index. - index = currentModelIndex ifTrue: - [currentItem := menu lastItem]]. - menu - addLine; - add: 'new window' target: self selector: #addNewWindow; - add: 'copy this window' target: self selector: #copyWindow; - add: 'remove this window' target: self selector: #removeCurrentWindow. - models size <= 1 ifTrue: - [menu lastItem isEnabled: false]. - menu selectItem: currentItem event: nil. - ^menu! Item was removed: - ----- Method: SearchBar>>spawn: (in category '*Tools') ----- - spawn: contentsString - - UIManager default edit: contentsString label: nil shouldStyle: Workspace shouldStyle! Item was removed: - PopUpMenu subclass: #SelectionMenu - instanceVariableNames: 'selections' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! Item was removed: - ----- Method: SelectionMenu class>>fromArray: (in category 'instance creation') ----- - fromArray: anArray - "Construct a menu from anArray. The elements of anArray must be either: - * A pair of the form: <label> <selector> - or * The 'dash' (or 'minus sign') symbol - - Refer to the example at the bottom of the method" - - | labelList lines selections anIndex | - labelList := OrderedCollection new. - lines := OrderedCollection new. - selections := OrderedCollection new. - anIndex := 0. - anArray do: - [:anElement | - anElement size = 1 - ifTrue: - [(anElement == #-) ifFalse: [self error: 'badly-formed menu constructor']. - lines add: anIndex] - ifFalse: - [anElement size = 2 ifFalse: [self error: 'badly-formed menu constructor']. - anIndex := anIndex + 1. - labelList add: anElement first. - selections add: anElement second]]. - ^ self labelList: labelList lines: lines selections: selections - - "(SelectionMenu fromArray: - #( ('first label' moja) - ('second label' mbili) - - - ('third label' tatu) - - - ('fourth label' nne) - ('fifth label' tano))) startUp"! Item was removed: - ----- Method: SelectionMenu class>>labelList: (in category 'instance creation') ----- - labelList: labelList - ^ self labelArray: labelList! Item was removed: - ----- Method: SelectionMenu class>>labelList:lines: (in category 'instance creation') ----- - labelList: labelList lines: lines - ^ self labelArray: labelList lines: lines! Item was removed: - ----- Method: SelectionMenu class>>labelList:lines:selections: (in category 'instance creation') ----- - labelList: labelList lines: lines selections: selections - ^ (self labelArray: labelList lines: lines) selections: selections! Item was removed: - ----- Method: SelectionMenu class>>labelList:selections: (in category 'instance creation') ----- - labelList: labelList selections: selections - ^ self - labelList: labelList - lines: #() - selections: selections! Item was removed: - ----- Method: SelectionMenu class>>labels:lines: (in category 'instance creation') ----- - labels: labels lines: linesArray - "Answer an instance of me whose items are in labels, with lines drawn - after each item indexed by linesArray. Labels can be either a string - with embedded CRs, or a collection of strings." - - (labels isString) - ifTrue: [^ super labels: labels lines: linesArray] - ifFalse: [^ super labelArray: labels lines: linesArray]! Item was removed: - ----- Method: SelectionMenu class>>labels:lines:selections: (in category 'instance creation') ----- - labels: labels lines: linesArray selections: selectionsArray - "Answer an instance of me whose items are in labels, with lines drawn - after each item indexed by linesArray. Labels can be either a string - with embedded CRs, or a collection of strings. Record the given array of - selections corresponding to the items in labels." - - | labelString | - (labels isString) - ifTrue: [labelString := labels] - ifFalse: [labelString := String streamContents: - [:s | - labels do: [:l | s nextPutAll: l; cr]. - s skip: -1]]. - ^ (self labels: labelString lines: linesArray) selections: selectionsArray - ! Item was removed: - ----- Method: SelectionMenu class>>labels:selections: (in category 'instance creation') ----- - labels: labels selections: selectionsArray - "Answer an instance of me whose items are in labels, recording - the given array of selections corresponding to the items in labels." - - ^ self - labels: labels - lines: #() - selections: selectionsArray! Item was removed: - ----- Method: SelectionMenu class>>selections: (in category 'instance creation') ----- - selections: selectionsArray - "Answer an instance of me whose labels and selections are identical." - - ^ self selections: selectionsArray lines: nil! Item was removed: - ----- Method: SelectionMenu class>>selections:lines: (in category 'instance creation') ----- - selections: selectionsArray lines: linesArray - "Answer an instance of me whose labels and selections are identical." - - ^ self - labelList: (selectionsArray collect: [:each | each asString]) - lines: linesArray - selections: selectionsArray! Item was removed: - ----- Method: SelectionMenu>>invokeOn: (in category 'basic control sequence') ----- - invokeOn: targetObject - "Pop up this menu and return the result of sending to the target object - the selector corresponding to the menu item selected by the user. Return - nil if no item is selected." - - | sel | - sel := self startUp. - sel = nil ifFalse: [^ targetObject perform: sel]. - ^ nil - - "Example: - (SelectionMenu labels: 'sin - cos - neg' lines: #() selections: #(sin cos negated)) invokeOn: 0.7"! Item was removed: - ----- Method: SelectionMenu>>invokeOn:orSendTo: (in category 'invocation') ----- - invokeOn: targetObject orSendTo: anObject - "Pop up the receiver, obtaining a selector; return the result of having the target object perform the selector. If it dos not understand the selector, give the alternate object a chance" - - | aSelector | - ^ (aSelector := self startUp) ifNotNil: - [(targetObject respondsTo: aSelector) - ifTrue: - [targetObject perform: aSelector] - ifFalse: - [anObject perform: aSelector]]! Item was removed: - ----- Method: SelectionMenu>>selections (in category 'accessing') ----- - selections - ^ selections! Item was removed: - ----- Method: SelectionMenu>>selections: (in category 'accessing') ----- - selections: selectionArray - selections := selectionArray! Item was removed: - ----- Method: SelectionMenu>>startUpWithCaption:at:allowKeyboard: (in category 'basic control sequence') ----- - startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean - "Overridden to return value returned by manageMarker. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" - - | index | - index := super startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. - (selections isNil or: [(index between: 1 and: selections size) not]) - ifTrue: [^ nil]. - ^ selections at: index! Item was removed: - StringHolder subclass: #SelectorBrowser - instanceVariableNames: 'selectorIndex selectorList classListIndex classList' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - - !SelectorBrowser commentStamp: 'tpr 10/15/2017 16:42' prior: 0! - A SelectorBrowser is more commonly referred to as the method finder; you can enter message names or more interestingly, example inputs and results to have the system try to find plausible methods that would satisfy the parameters. See SelectorBrowser>>#byExample for much more detail.! Item was removed: - ----- Method: SelectorBrowser class>>prototypicalToolWindow (in category 'instance creation') ----- - prototypicalToolWindow - "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" - - | aWindow | - aWindow := ToolBuilder build: self new. - aWindow setLabel: 'Selector Browser'. - aWindow applyModelExtent. - ^ aWindow! Item was removed: - ----- Method: SelectorBrowser>>buildClassListWith: (in category 'toolbuilder') ----- - buildClassListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #classList; - getIndex: #classListIndex; - setIndex: #classListIndex:; - keyPress: #arrowKey:from:. - ^listSpec - ! Item was removed: - ----- Method: SelectorBrowser>>buildEditViewWith: (in category 'toolbuilder') ----- - buildEditViewWith: builder - | textSpec | - textSpec := builder pluggableInputFieldSpec new. - textSpec - model: self; - getText: #contents; - setText: #contents:notifying:; - selection: #contentsSelection; - menu: #codePaneMenu:shifted:. - ^textSpec! Item was removed: - ----- Method: SelectorBrowser>>buildExamplePaneWith: (in category 'toolbuilder') ----- - buildExamplePaneWith: builder - | textSpec | - textSpec := builder pluggableTextSpec new. - textSpec - model: self; - getText: #byExample; - setText: #byExample:; - selection: #contentsSelection; - menu: #codePaneMenu:shifted:. - ^textSpec! Item was removed: - ----- Method: SelectorBrowser>>buildMessageListWith: (in category 'toolbuilder') ----- - buildMessageListWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #messageList; - getIndex: #messageListIndex; - setIndex: #messageListIndex:; - menu: #selectorMenu:; - keyPress: #messageListKey:from:. - ^listSpec - ! Item was removed: - ----- Method: SelectorBrowser>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - "Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spawns a full browser on it. Answer the window - SelectorBrowser new open " - | windowSpec | - selectorIndex := classListIndex := 0. - windowSpec := self buildWindowWith: builder specs: { - (0 at 0 corner: 0.5 at 0.14) -> [self buildEditViewWith: builder]. - (0 at 0.14 corner: 0.5 at 0.6) -> [self buildMessageListWith: builder]. - (0.5 at 0 corner: 1 at 0.6) -> [self buildClassListWith: builder]. - (0 at 0.6 corner: 1 at 1) -> [self buildExamplePaneWith: builder]. - }. - ^builder build: windowSpec! Item was removed: - ----- Method: SelectorBrowser>>byExample (in category 'example pane') ----- - byExample - "The comment in the bottom pane" - - false ifTrue: [MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10)]. - "to keep the method methodFor: from being removed from the system" - - ^ 'Type a fragment of a selector in the top pane. Accept it. - - Or, use an example to find a method in the system. Type receiver, args, and answer in the top pane with periods between the items. 3. 4. 7 - - Or, in this pane, use examples to find a method in the system. Select the line of code and choose "print it". - - MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10). - This will discover (data1 + data2). - - You supply inputs and answers and the system will find the method. Each inner array is a list of inputs. It contains the receiver and zero or more arguments. For Booleans and any computed arguments, use brace notation. - - MethodFinder methodFor: { {1. 3}. true. {20. 10}. false}. - This will discover the expressions (data1 < data2), (data2 > data1), and many others. - - MethodFinder methodFor: { {''29 Apr 1999'' asDate}. ''Thursday''. - {''30 Apr 1999'' asDate}. ''Friday'' }. - This will discover the expression (data1 weekday) - - Receiver and arguments do not have to be in the right order. - See MethodFinder.verify for more examples.'! Item was removed: - ----- Method: SelectorBrowser>>byExample: (in category 'example pane') ----- - byExample: newText - "Don't save it" - ^ true! Item was removed: - ----- Method: SelectorBrowser>>classList (in category 'class list') ----- - classList - ^ classList ifNil: [#()]! Item was removed: - ----- Method: SelectorBrowser>>classListIndex (in category 'class list') ----- - classListIndex - ^ classListIndex! Item was removed: - ----- Method: SelectorBrowser>>classListIndex: (in category 'class list') ----- - classListIndex: anInteger - - classListIndex := anInteger. - classListIndex > 0 ifTrue: - [self changed: #startNewBrowser. "MVC view will terminate control to prepare for new browser" - ToolSet browse: self selectedClass selector: self selectedMessageName. - "classListIndex := 0"] - ! Item was removed: - ----- Method: SelectorBrowser>>classListSelectorTitle (in category 'class list') ----- - classListSelectorTitle - ^ 'Class List Menu'! Item was removed: - ----- Method: SelectorBrowser>>contents:notifying: (in category 'example pane') ----- - contents: aString notifying: aController - "Take what the user typed and find all selectors containing it" - - | tokens | - contents := aString. - classList := #(). classListIndex := 0. - selectorIndex := 0. - tokens := contents asString findTokens: ' .'. - selectorList := Cursor wait showWhile: [ - tokens size = 1 - ifTrue: [(Symbol selectorsContaining: contents asString) asArray - sort: [:x :y | x asLowercase <= y asLowercase]] - ifFalse: [self quickList]]. "find selectors from a single example of data" - self changed: #messageList. - self changed: #classList. - ^ true! Item was removed: - ----- Method: SelectorBrowser>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.45 g: 0.9 b: 0.9)! Item was removed: - ----- Method: SelectorBrowser>>implementors (in category 'selector functions') ----- - implementors - | aSelector | - (aSelector := self selectedMessageName) ifNotNil: - [self systemNavigation browseAllImplementorsOf: aSelector]! Item was removed: - ----- Method: SelectorBrowser>>initialExtent (in category 'message list') ----- - initialExtent - - ^ 350 at 250 - ! Item was removed: - ----- Method: SelectorBrowser>>labelString (in category 'user interface') ----- - labelString - - ^ 'Selector Browser' translated! Item was removed: - ----- Method: SelectorBrowser>>listFromResult: (in category 'selector finding') ----- - listFromResult: resultOC - "ResultOC is of the form #('(data1 op data2)' '(...)'). Answer a sorted array." - - (resultOC first beginsWith: 'no single method') ifTrue: [^ #()]. - ^ resultOC sorted: [:a :b | - (a copyFrom: 6 to: a size) < (b copyFrom: 6 to: b size)]. - - ! Item was removed: - ----- Method: SelectorBrowser>>mainSelectorMenu: (in category 'selector list') ----- - mainSelectorMenu: aMenu - - <selectorMenu> - ^ aMenu addList: #( - ('senders (n)' senders) - ('implementors (m)' implementors) - ('copy selector to clipboard' copyName)); - yourself - ! Item was removed: - ----- Method: SelectorBrowser>>markMatchingClasses (in category 'message list') ----- - markMatchingClasses - "If an example is used, mark classes matching the example instance with an asterisk." - - | unmarkedClassList firstPartOfSelector receiverString receiver | - - self flag: #mref. "allows for old-fashioned style" - - "Only 'example' queries can be marked." - (contents asString includes: $.) ifFalse: [^ self]. - - unmarkedClassList := classList copy. - - "Get the receiver object of the selected statement in the message list." - firstPartOfSelector := (Scanner new scanTokens: (selectorList at: selectorIndex)) second. - receiverString := (ReadStream on: (selectorList at: selectorIndex)) - upToAll: firstPartOfSelector. - receiver := Compiler evaluate: receiverString. - - unmarkedClassList do: [ :classAndMethod | | class | - (classAndMethod isKindOf: MethodReference) ifTrue: [ - (receiver isKindOf: classAndMethod actualClass) ifTrue: [ - classAndMethod stringVersion: '*', classAndMethod stringVersionDefault. - ] - ] ifFalse: [ - class := Compiler evaluate: - ((ReadStream on: classAndMethod) upToAll: firstPartOfSelector). - (receiver isKindOf: class) ifTrue: [ - classList add: '*', classAndMethod. - classList remove: classAndMethod - ] - ]. - ]. - ! Item was removed: - ----- Method: SelectorBrowser>>messageList (in category 'message list') ----- - messageList - "Find all the selectors containing what the user typed in." - - ^ selectorList ifNil: [#()]! Item was removed: - ----- Method: SelectorBrowser>>messageListIndex (in category 'message list') ----- - messageListIndex - "Answer the index of the selected message selector." - - ^ selectorIndex! Item was removed: - ----- Method: SelectorBrowser>>messageListIndex: (in category 'message list') ----- - messageListIndex: anInteger - "Set the selected message selector to be the one indexed by anInteger. - Find all classes it is in." - selectorIndex := anInteger. - selectorIndex = 0 - ifTrue: [^ self]. - classList := self systemNavigation allImplementorsOf: self selectedMessageName. - self markMatchingClasses. - classListIndex := 0. - self changed: #messageListIndex. - "update my selection" - self changed: #classList! Item was removed: - ----- Method: SelectorBrowser>>messageListKey:from: (in category 'message list') ----- - messageListKey: aChar from: view - "Respond to a command key. Handle (m) and (n) here, - else defer to the StringHolder behaviour." - - aChar == $m ifTrue: [^ self implementors]. - aChar == $n ifTrue: [^ self senders]. - super messageListKey: aChar from: view - ! Item was removed: - ----- Method: SelectorBrowser>>open (in category 'toolbuilder') ----- - open - "Create a Browser that lets you type part of a selector, shows a list of selectors, - shows the classes of the one you chose, and spwns a full browser on it. - SelectorBrowser new open - " - ^ToolBuilder open: self! Item was removed: - ----- Method: SelectorBrowser>>quickList (in category 'selector finding') ----- - quickList - "Compute the selectors for the single example of receiver and args, in the very top pane" - - | data result resultArray dataStrings mf dataObjects aa statements | - data := contents asString withBlanksTrimmed. - mf := MethodFinder new. - data := mf cleanInputs: data. "remove common mistakes" - dataObjects := Compiler evaluate: '{', data, '}'. "#( data1 data2 result )" - statements := (Compiler new parse: 'zort ' , data in: Object notifying: nil) - body statements select: [:each | (each isKindOf: ReturnNode) not]. - dataStrings := statements collect: - [:node | String streamContents: - [:strm | (node isMessage) ifTrue: [strm nextPut: $(]. - node shortPrintOn: strm. - (node isMessage) ifTrue: [strm nextPut: $)].]]. - dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()]. - dataObjects := Array with: dataObjects allButLast with: dataObjects last. "#( (data1 - data2) result )" - result := mf load: dataObjects; findMessage. - (result first beginsWith: 'no single method') ifFalse: [ - aa := self testObjects: dataObjects strings: dataStrings. - dataObjects := aa second. dataStrings := aa third]. - resultArray := self listFromResult: result. - resultArray isEmpty ifTrue: [self inform: result first]. - - dataStrings size = (dataObjects first size + 1) ifTrue: - [resultArray := resultArray collect: [:expression | | newExp | - newExp := expression. - dataObjects first withIndexDo: [:lit :i | - newExp := newExp copyReplaceAll: 'data', i printString - with: (dataStrings at: i)]. - newExp, ' --> ', dataStrings last]]. - - ^ resultArray! Item was removed: - ----- Method: SelectorBrowser>>searchResult: (in category 'example pane') ----- - searchResult: anExternalSearchResult - - self contents: ''. - classList := #(). classListIndex := 0. - selectorIndex := 0. - selectorList := self listFromResult: anExternalSearchResult. - self changed: #messageList. - self changed: #classList. - self changed: #contents - ! Item was removed: - ----- Method: SelectorBrowser>>selectedClass (in category 'class list') ----- - selectedClass - "Answer the currently selected class." - - | pairString | - - self flag: #mref. "allows for old-fashioned style" - - classListIndex = 0 ifTrue: [^nil]. - pairString := classList at: classListIndex. - (pairString isKindOf: MethodReference) ifTrue: [ - ^pairString actualClass - ]. - (pairString includes: $*) ifTrue: [pairString := pairString allButFirst]. - MessageSet - parse: pairString - toClassAndSelector: [:cls :sel | ^ cls].! Item was removed: - ----- Method: SelectorBrowser>>selectedClassName (in category 'accessing') ----- - selectedClassName - "Answer the name of the currently selected class." - - classListIndex = 0 ifTrue: [^nil]. - ^ self selectedClass name! Item was removed: - ----- Method: SelectorBrowser>>selectedMessageName (in category 'accessing') ----- - selectedMessageName - "Answer the name of the currently selected message or nil if not a known Symbol." - - | example tokens | - selectorIndex = 0 ifTrue: [^nil]. - example := selectorList at: selectorIndex. - tokens := Scanner new scanTokens: example. - tokens size = 1 ifTrue: [^ tokens first]. - tokens first == #'^' ifTrue: [^ nil]. - (tokens second includes: $:) ifTrue: [^ example findSelector]. - ^Symbol lookup: tokens second! Item was removed: - ----- Method: SelectorBrowser>>selectorList: (in category 'selector list') ----- - selectorList: anExternalList - - self contents: ''. - classList := #(). classListIndex := 0. - selectorIndex := 0. - selectorList := anExternalList. - self changed: #messageList. - self changed: #classList. - self changed: #contents - - ! Item was removed: - ----- Method: SelectorBrowser>>selectorMenu: (in category 'selector list') ----- - selectorMenu: aMenu - ^ self menu: aMenu for: #(selectorMenu selectorMenuShifted:) - ! Item was removed: - ----- Method: SelectorBrowser>>selectorMenuTitle (in category 'selector list') ----- - selectorMenuTitle - ^ self selectedMessageName ifNil: ['<no selection>']! Item was removed: - ----- Method: SelectorBrowser>>senders (in category 'selector functions') ----- - senders - | aSelector | - (aSelector := self selectedMessageName) ifNotNil: - [self systemNavigation browseAllCallsOn: aSelector]! Item was removed: - ----- Method: SelectorBrowser>>testObjects:strings: (in category 'selector finding') ----- - testObjects: dataObjects strings: dataStrings - | dataObjs dataStrs selectors classes didUnmodifiedAnswer | - "Try to make substitutions in the user's inputs and search for the selector again. - 1 no change to answer. - 2 answer Array -> OrderedCollection. - 2 answer Character -> String - 4 answer Symbol or String of len 1 -> Character - For each of these, try straight, and try converting args: - Character -> String - Symbol or String of len 1 -> Character - Return array with result, dataObjects, dataStrings. Don't ever do a find on the same set of data twice." - - dataObjs := dataObjects. dataStrs := dataStrings. - selectors := {#asString. #first. #asOrderedCollection}. - classes := {Character. String. Array}. - didUnmodifiedAnswer := false. - selectors withIndexDo: [:ansSel :ansInd | | ds do result answerMod | "Modify the answer object" - answerMod := false. - do := dataObjs copyTwoLevel. ds := dataStrs copy. - (dataObjs last isKindOf: (classes at: ansInd)) ifTrue: [ - ((ansSel ~~ #first) or: [dataObjs last size = 1]) ifTrue: [ - do at: do size put: (do last perform: ansSel). "asString" - ds at: ds size put: ds last, ' ', ansSel. - result := MethodFinder new load: do; findMessage. - (result first beginsWith: 'no single method') ifFalse: [ - "found a selector!!" - ^ Array with: result first with: do with: ds]. - answerMod := true]]. - - selectors allButLast withIndexDo: [:argSel :argInd | | ddo dds | "Modify an argument object" - "for args, no reason to do Array -> OrderedCollection. Identical protocol." - didUnmodifiedAnswer not | answerMod ifTrue: [ - ddo := do copyTwoLevel. dds := ds copy. - dataObjs first withIndexDo: [:arg :ind | - (arg isKindOf: (classes at: argInd)) ifTrue: [ - ((argSel ~~ #first) or: [arg size = 1]) ifTrue: [ - ddo first at: ind put: ((ddo first at: ind) perform: argSel). "asString" - dds at: ind put: (dds at: ind), ' ', argSel. - result := MethodFinder new load: ddo; findMessage. - (result first beginsWith: 'no single method') ifFalse: [ - "found a selector!!" - ^ Array with: result first with: ddo with: dds] . - didUnmodifiedAnswer not & answerMod not ifTrue: [ - didUnmodifiedAnswer := true]. - ]]]]]. - ]. - ^ Array with: 'no single method does that function' with: dataObjs with: dataStrs! Item was removed: - ----- Method: Set>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Set'! Item was removed: - ----- Method: Set>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^ SetInspector! Item was removed: - CollectionInspector subclass: #SetInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !SetInspector commentStamp: 'ct 1/12/2020 15:21' prior: 0! - I am an inspector that is specialized for inspecting Sets. I display the elements of the set like elements of an array. Note that the indices, being phyical locations in the hash table, are not meaningful outside of the set.! Item was removed: - ----- Method: SetInspector>>elementGetterAt: (in category 'private') ----- - elementGetterAt: index - - ^ [:set | (set array at: index) enclosedSetElement]! Item was removed: - ----- Method: SetInspector>>elementIndices (in category 'private') ----- - elementIndices - "In the set's internal array, extract the indices that point to actual elements." - - | numIndices | - (numIndices := self objectSize) = 0 - ifTrue: [^#()]. - - ^ Array - new: numIndices - streamContents: [:stream | - self object array withIndexDo: [:element :index | - (self isElementValid: element) ifTrue: [stream nextPut: index]]]! Item was removed: - ----- Method: SetInspector>>elementSetterAt: (in category 'private') ----- - elementSetterAt: index - "Because of sets are hashed collections, we have to use the public interface, which means removing the element the index is pointing to first -- and only then can we add the new element." - - ^ [:set :element | - set remove: (set array at: index) enclosedSetElement. - set add: element]! Item was removed: - ----- Method: SetInspector>>isElementValid: (in category 'private') ----- - isElementValid: anElement - - ^ anElement notNil! Item was removed: - ----- Method: SetInspector>>replaceSelectionValue: (in category 'selection') ----- - replaceSelectionValue: anObject - "After replacing the value, we have to scan for the field that now contains anObject." - - (super replaceSelectionValue: anObject) ifTrue: [ - self updateFields. - self selectFieldSuchThat: [:field | [(field getValueFor: self) == anObject] ifError: [false] ]].! Item was removed: - ----- Method: StandardFileStream>>dirAndFileName (in category '*Tools-FileList') ----- - dirAndFileName - "A temporary solution for supporting project loading via drag and drop." - - ^{ self directory. self localName }! Item was removed: - Object subclass: #StandardToolSet - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Base'! - - !StandardToolSet commentStamp: '<historical>' prior: 0! - Main comment stating the purpose of this class and relevant relationship to other classes. - - Possible useful expressions for doIt or printIt. - - Structure: - instVar1 type -- comment about the purpose of instVar1 - instVar2 type -- comment about the purpose of instVar2 - - Any further useful comments about the general approach of this implementation.! Item was removed: - ----- Method: StandardToolSet class>>basicInspect: (in category 'inspecting') ----- - basicInspect: anObject - "Open a basic inspector on the given object." - ^ BasicInspector openOn: anObject! Item was removed: - ----- Method: StandardToolSet class>>browse:selector: (in category 'browsing') ----- - browse: aClass selector: aSelector - "Open a browser" - ^SystemBrowser default fullOnClass: aClass selector: aSelector! Item was removed: - ----- Method: StandardToolSet class>>browseCategory: (in category 'browsing') ----- - browseCategory: aCategory - - ^ SystemBrowser default fullOnCategory: aCategory! Item was removed: - ----- Method: StandardToolSet class>>browseChangeSetsWithClass:selector: (in category 'browsing') ----- - browseChangeSetsWithClass: aClass selector: aSelector - "Browse all the change sets with the given class/selector" - ^ChangeSorter browseChangeSetsWithClass: aClass selector: aSelector! Item was removed: - ----- Method: StandardToolSet class>>browseClass: (in category 'browsing') ----- - browseClass: aClass - "Open a browser" - ^SystemBrowser default fullOnClass: aClass.! Item was removed: - ----- Method: StandardToolSet class>>browseClass:category: (in category 'browsing') ----- - browseClass: aClass category: aCategory - "Open a browser for a class selecting a given message category." - - ^ SystemBrowser default - fullOnClass: aClass - category: aCategory! Item was removed: - ----- Method: StandardToolSet class>>browseClassCommentOf: (in category 'browsing') ----- - browseClassCommentOf: aClass - - ^ SystemBrowser default fullOnClassComment: aClass! Item was removed: - ----- Method: StandardToolSet class>>browseEnvironment: (in category 'browsing') ----- - browseEnvironment: anEnvironment - - ^ SystemBrowser default fullOnEnvironment: anEnvironment! Item was removed: - ----- Method: StandardToolSet class>>browseHierarchy:selector: (in category 'browsing') ----- - browseHierarchy: aClass selector: aSelector - "Open a browser" - - ^ HierarchyBrowser fullOnClass: aClass selector: aSelector.! Item was removed: - ----- Method: StandardToolSet class>>browseMessageCategory:inClass: (in category 'browsing') ----- - browseMessageCategory: aCategory inClass: aClass - "Open a message category browser." - - ^ SystemBrowser default - newOnClass: aClass messageCategory: aCategory! Item was removed: - ----- Method: StandardToolSet class>>browseMessageNames: (in category 'browsing') ----- - browseMessageNames: aString - ^(MessageNames methodBrowserSearchingFor: aString) openInWorld! Item was removed: - ----- Method: StandardToolSet class>>browseMessageSet:name:autoSelect: (in category 'browsing') ----- - browseMessageSet: messageList name: title autoSelect: autoSelectString - "Open a message set or message-trace browser, depending on the #traceMessages setting." - ^ Preferences traceMessages - ifTrue: - [ MessageTrace - openMessageList: messageList - name: title - autoSelect: autoSelectString ] - ifFalse: - [ MessageSet - openMessageList: messageList - name: title - autoSelect: autoSelectString ]! Item was removed: - ----- Method: StandardToolSet class>>browseMethod: (in category 'browsing') ----- - browseMethod: aCompiledMethod - "Browse aCompiledMethod on the most convenient possible way, using a System Browser, a Versions Browser, or an Inspector." - - aCompiledMethod isInstalled - ifTrue: [^ self browse: aCompiledMethod methodClass selector: aCompiledMethod selector]. - (aCompiledMethod methodClass changeRecordsAt: aCompiledMethod selector) - ifNotNil: [^ self browseMethodVersion: aCompiledMethod]. - ^ self inspect: aCompiledMethod! Item was removed: - ----- Method: StandardToolSet class>>browseMethodVersion: (in category 'browsing') ----- - browseMethodVersion: aCompiledMethod - - ^ VersionsBrowser browseMethod: aCompiledMethod! Item was removed: - ----- Method: StandardToolSet class>>browsePackage: (in category 'browsing') ----- - browsePackage: aPackageInfo - - ^ PackagePaneBrowser fullOnPackage: aPackageInfo! Item was removed: - ----- Method: StandardToolSet class>>browseVersionsOf:selector: (in category 'browsing') ----- - browseVersionsOf: class selector: selector - "Open and answer a browser on versions of the method. - If the method doesn't exist try and find version from the current change set. - If not found there, answer nil." - | methodOrNil methodCategory | - methodOrNil := class compiledMethodAt: selector ifAbsent: []. - methodOrNil ifNil: - [(ChangeSet current methodInfoFromRemoval: {class name. selector}) - ifNil: [^nil] - ifNotNil: - [:pair| - methodOrNil := CompiledMethod toReturnSelfTrailerBytes: - (CompiledMethodTrailer new sourcePointer: pair first). - methodCategory := pair second]]. - ^VersionsBrowser - browseVersionsOf: methodOrNil - class: class theNonMetaClass - meta: class isMeta - category: (methodCategory ifNil: [class organization categoryOfElement: selector]) - selector: selector! Item was removed: - ----- Method: StandardToolSet class>>codeCompletionAround:textMorph:keyStroke: (in category 'completion') ----- - codeCompletionAround: aBlock textMorph: aTextMorph keyStroke: evt - ^ aBlock value! Item was removed: - ----- Method: StandardToolSet class>>debugException: (in category 'debugging') ----- - debugException: anException - "For convenience. Construct a helper process to debug an exception that occurred in the active process later on so that the active process can (try to) resume. Uses a temporary variable to access and copy the signaler context now before it gets GC'ed." - - | helperProcess | - helperProcess := (Process - forContext: anException signalerContext copyStack - priority: Processor activeProcess priority) - shouldResumeFromDebugger: false; - yourself. - - Project current addDeferredUIMessage: [ - helperProcess - debugWithTitle: anException description - full: false - contents: ((anException isKindOf: Warning) - ifTrue: [anException messageText])].! Item was removed: - ----- Method: StandardToolSet class>>debugProcess:context:label:contents:fullView: (in category 'debugging') ----- - debugProcess: aProcess context: aContext label: aString contents: contents fullView: aBool - - (aProcess isTerminated and: [aString isNil or: [aString beginsWith: 'Debug it']]) ifTrue: [ - ^ Project uiManager inform: 'Nothing to debug. Process has terminated.\Expression optimized.' translated withCRs]. - - ^ Debugger - openOn: aProcess - context: aContext - label: aString - contents: contents - fullView: aBool! Item was removed: - ----- Method: StandardToolSet class>>debugSyntaxError: (in category 'debugging') ----- - debugSyntaxError: aSyntaxErrorNotification - - ^ SyntaxError open: aSyntaxErrorNotification! Item was removed: - ----- Method: StandardToolSet class>>explore: (in category 'inspecting') ----- - explore: anObject - - ^ ObjectExplorer openOn: anObject! Item was removed: - ----- Method: StandardToolSet class>>explore:label: (in category 'inspecting') ----- - explore: anObject label: label - - ^ ObjectExplorer openOn: anObject withLabel: label! Item was removed: - ----- Method: StandardToolSet class>>handleError: (in category 'debugging - handlers') ----- - handleError: anError - "Double dispatch. Let the processor take care of that error, which usually calls back here to #debugProcess:..." - - ^ Processor - debugContext: anError signalerContext - title: anError description - full: false - contents: nil! Item was removed: - ----- Method: StandardToolSet class>>handleRecursiveError: (in category 'debugging - handlers') ----- - handleRecursiveError: description - - ^ Project current recursiveError: description! Item was removed: - ----- Method: StandardToolSet class>>handleSyntaxError: (in category 'debugging - handlers') ----- - handleSyntaxError: aSyntaxErrorNotification - "Double dispatch. Let the current project manage processes, which usually calls back into #debugSyntaxError:." - - ^ Project current syntaxError: aSyntaxErrorNotification! Item was removed: - ----- Method: StandardToolSet class>>handleUserInterruptRequest: (in category 'debugging - handlers') ----- - handleUserInterruptRequest: aString - "Double dispatch. Let the current project manage processes, which usually calls back here eventually into #debugProcess..." - - Preferences cmdDotEnabled ifFalse: [^ self]. - ^ Project current interruptName: aString! Item was removed: - ----- Method: StandardToolSet class>>handleWarning: (in category 'debugging - handlers') ----- - handleWarning: aWarning - "Double dispatch. Let the processor take care of that warning, which usually calls back here to #debugProcess:..." - - | message | - message := '{1}\\{2}' withCRs asText format: { - "First, show the actual text of this warning." - aWarning messageText. - "Second, append some helpful information that apply to all kinds of warnings." - ('{1} {2}' asText format: { - 'Select "Proceed" to continue or close this window to cancel the operation.' translated. - 'If you do not want to be interrupted anymore, you can {1} this kind of warning. You can also {2}, which resets such warnings on the next image startup.' translated asText format: { - "Provide clickable text links so that the user can directly suppress warnings." - 'always suppress' asText - addAttribute: (PluggableTextAttribute evalBlock: [ - aWarning class suppressWarnings. - self inform: ('All ''{1}'' warnings will be suppressed.' translated format: {aWarning class name})]). - 'suppress temporarily' asText - addAttribute: (PluggableTextAttribute evalBlock: [ - aWarning class suppressAndResetOnStartUp. - self inform: ('All ''{1}'' warnings will be suppressed\and reset on the next image startup.' translated withCRs format: {aWarning class name})])}. - }) addAttribute: ( - "Show this helpful information in a smaller font." - TextFontReference toFont: Preferences standardButtonFont)}. - - ^ Processor - debugContext: aWarning signalerContext - title: 'Warning' translated - full: false - contents: message! Item was removed: - ----- Method: StandardToolSet class>>initialize (in category 'class initialization') ----- - initialize - ToolSet register: self.! Item was removed: - ----- Method: StandardToolSet class>>inspect: (in category 'inspecting') ----- - inspect: anObject - "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." - ^ anObject inspectorClass openOn: anObject! Item was removed: - ----- Method: StandardToolSet class>>inspect:label: (in category 'inspecting') ----- - inspect: anObject label: aString - "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." - ^ anObject inspectorClass openOn: anObject withLabel: aString! Item was removed: - ----- Method: StandardToolSet class>>menuItems (in category 'menu') ----- - menuItems - "Answer the menu items available for this tool set" - ^#( - ('class browser' #openClassBrowser) - ('workspace' #openWorkspace) - ('file list' #openFileList) - ('package pane browser' #openPackagePaneBrowser) - ('process browser' #openProcessBrowser) - - - ('method finder' #openSelectorBrowser) - ('message names' #openMessageNames) - - - ('simple change sorter' #openChangeSorter) - ('dual change sorter' #openDualChangeSorter) - ) - ! Item was removed: - ----- Method: StandardToolSet class>>openChangeSorter (in category 'menu') ----- - openChangeSorter - ToolBuilder open: ChangeSorter new! Item was removed: - ----- Method: StandardToolSet class>>openChangedMessageSet: (in category 'browsing') ----- - openChangedMessageSet: aChangeSet - "Open a ChangedMessageSet for aChangeSet" - ChangedMessageSet openFor: aChangeSet! Item was removed: - ----- Method: StandardToolSet class>>openClassBrowser (in category 'menu') ----- - openClassBrowser - SystemBrowser default open! Item was removed: - ----- Method: StandardToolSet class>>openClassListBrowser:title: (in category 'browsing') ----- - openClassListBrowser: anArray title: aString - "Open a class list browser on the list of classes named" - - ^ClassListBrowser newOnClassesNamed: anArray label: aString - ! Item was removed: - ----- Method: StandardToolSet class>>openDualChangeSorter (in category 'menu') ----- - openDualChangeSorter - ToolBuilder open: DualChangeSorter new! Item was removed: - ----- Method: StandardToolSet class>>openFileList (in category 'menu') ----- - openFileList - FileList open! Item was removed: - ----- Method: StandardToolSet class>>openMessageNames (in category 'menu') ----- - openMessageNames - "Bring a MessageNames tool to the front" - MessageNames openMessageNames! Item was removed: - ----- Method: StandardToolSet class>>openPackagePaneBrowser (in category 'menu') ----- - openPackagePaneBrowser - PackagePaneBrowser openBrowser.! Item was removed: - ----- Method: StandardToolSet class>>openProcessBrowser (in category 'menu') ----- - openProcessBrowser - ProcessBrowser open! Item was removed: - ----- Method: StandardToolSet class>>openSelectorBrowser (in category 'menu') ----- - openSelectorBrowser - ToolBuilder open: SelectorBrowser new! Item was removed: - ----- Method: StandardToolSet class>>openWorkspace (in category 'menu') ----- - openWorkspace - Workspace open! Item was removed: - ----- Method: StandardToolSet class>>unload (in category 'class initialization') ----- - unload - ToolSet unregister: self.! Item was removed: - ----- Method: Stream class>>toolIcon (in category '*Tools-icons') ----- - toolIcon - - ^ #stream! Item was removed: - ----- Method: String class>>toolIcon (in category '*Tools-icons') ----- - toolIcon - - ^ #string! Item was removed: - ----- Method: String>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'String'! Item was removed: - ----- Method: StringHolder class>>codePaneMenu:shifted: (in category '*Tools-yellow button menu') ----- - codePaneMenu: aMenu shifted: shifted - "Utility method for the 'standard' codePane menu" - aMenu addList: (shifted - ifTrue:[self shiftedYellowButtonMenuItems] - ifFalse:[self yellowButtonMenuItems]). - ^aMenu! Item was removed: - ----- Method: StringHolder class>>open (in category '*Tools') ----- - open - ^ (Smalltalk at: #Workspace ifAbsent:[self]) new openLabel: 'Workspace' - ! Item was removed: - ----- Method: StringHolder class>>openLabel: (in category '*Tools') ----- - openLabel: aString - - ^self new openLabel: aString! Item was removed: - ----- Method: StringHolder class>>shiftedYellowButtonMenuItems (in category '*Tools-yellow button menu') ----- - shiftedYellowButtonMenuItems - "Returns the standard yellow button menu items" - | entries | - entries := OrderedCollection withAll: - { - #-. - {'explain' translated. #explain}. - {'pretty print' translated. #prettyPrint}. - {'pretty print with color' translated. #prettyPrintWithColor}. - {'file it in (G)' translated. #fileItIn}. - {'spawn (o)' translated. #spawn}. - #-. - {'browse it (b)' translated. #browseIt}. - {'senders of it (n)' translated. #sendersOfIt}. - {'implementors of it (m)' translated. #implementorsOfIt}. - {'references to it (N)' translated. #referencesToIt}. - #-. - {'selectors containing it (W)' translated. #methodNamesContainingIt}. - {'method strings with it (E)' translated. #methodStringsContainingit}. - {'method source with it' translated. #methodSourceContainingIt}. - {'class names containing it' translated. #classNamesContainingIt}. - {'class comments with it' translated. #classCommentsContainingIt}. - {'change sets with it' translated. #browseChangeSetsWithSelector}. - #-. - {'save contents to file...' translated. #saveContentsInFile}. - {'send contents to printer' translated. #sendContentsToPrinter}. - {'printer setup' translated. #printerSetup}. - #-. - }. - Smalltalk isMorphic ifFalse: [ entries add: - {'special menu...' translated. #presentSpecialMenu}.]. - entries add: - {'more...' translated. #yellowButtonActivity}. - ^ entries! Item was removed: - ----- Method: StringHolder class>>yellowButtonMenuItems (in category '*Tools-yellow button menu') ----- - yellowButtonMenuItems - "Returns the standard yellow button menu items" - ^{ - #-. - {'set font... (k)' translated. #offerFontMenu}. - {'set style... (K)' translated. #changeStyle}. - {'set alignment... (u)' translated. #chooseAlignment}. - #-. - {'make project link (P)' translated. #makeProjectLink}. - #-. - {'find...(f)' translated. #find}. - {'find again (g)' translated. #findAgain}. - {'find and replace ...' translated. #findReplace}. - {'do/replace again (j)' translated. #again}. - #-. - {'undo (z)' translated. #undo}. - {'redo (Z)' translated. #redo}. - #-. - {'copy (c)' translated. #copySelection}. - {'cut (x)' translated. #cut}. - {'paste (v)' translated. #paste}. - {'paste...' translated. #pasteRecent}. - #-. - {'do it (d)' translated. #doIt}. - {'debug it (D)' translated. #debugIt}. - {'print it (p)' translated. #printIt}. - {'inspect it (i)' translated. #inspectIt}. - {'explore it (I)' translated. #exploreIt}. - {'button for it' translated. #buttonForIt}. - {'tally it' translated. #tallyIt}. - {'spy on it' translated. #spyOnIt}. - #-. - {'accept (s)' translated. #accept}. - {'cancel (l)' translated. #cancelSafely}. - #-. - {'show bytecodes' translated. #showBytecodes}. - #-. - {'copy as html' translated. #copyHtmlSelection}. - #-. - {'more...' translated. #shiftedTextPaneMenuRequest}. - }! Item was removed: - ----- Method: StringHolder>>browseAllMessages (in category '*Tools') ----- - browseAllMessages - "Create and schedule a message set browser on all implementors of all the messages sent by the current method." - - | aClass aName method filteredList | - (aName := self selectedMessageName) ifNotNil: [ - method := (aClass := self selectedClassOrMetaClass) compiledMethodAt: aName. - filteredList := method messages reject: - [:each | #(new initialize = ) includes: each]. - self systemNavigation browseAllImplementorsOfList: filteredList sorted - title: 'All messages sent in ', aClass name, '.', aName] - ! Item was removed: - ----- Method: StringHolder>>browseClass (in category '*Tools') ----- - browseClass - "Open an class browser on this class and method" - ^ self browseMethodFull.! Item was removed: - ----- Method: StringHolder>>browseClassHierarchy (in category '*Tools') ----- - browseClassHierarchy - "Create and schedule a class list browser on the receiver's hierarchy." - - self systemNavigation - spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil" - selector: self selectedMessageName! Item was removed: - ----- Method: StringHolder>>browseClassRefs (in category '*Tools-traits') ----- - browseClassRefs - - self selectedClass ifNotNil: [:cls | - cls isTrait ifFalse: [self systemNavigation browseAllCallsOnClass: cls]] - ! Item was removed: - ----- Method: StringHolder>>browseImplementors (in category '*Tools') ----- - browseImplementors - - self browseAllImplementorsOf: self selectedMessageName requestor: #modelMenu.! Item was removed: - ----- Method: StringHolder>>browseLocalImplementors (in category '*Tools') ----- - browseLocalImplementors - "Present a menu of all messages sent by the currently selected message. - Open a message set browser of all implementors of the message chosen in or below - the selected class. - Do nothing if no message is chosen." - self getSelectorAndSendQuery: #browseAllImplementorsOf:localTo: - to: self systemNavigation - with: { self selectedClass }! Item was removed: - ----- Method: StringHolder>>browseLocalSenders (in category '*Tools') ----- - browseLocalSenders - self selectedClassOrMetaClass ifNotNil: - [:cls| | token | - token := UIManager default request: 'browse for selector or literal'. - token isEmpty ifTrue: [^self]. - Scanner new - typedScan: token - do: [:scannedToken :tokenType| - token := tokenType = #word - ifTrue: - [(Symbol lookup: token) - ifNil: [^UIManager default inform: 'no such selector: ', token] - ifNotNil: [:symbol| symbol]] - ifFalse: - [scannedToken]. - self systemNavigation browseAllCallsOn: token localTo: cls]]! Item was removed: - ----- Method: StringHolder>>browseLocalSendersOfMessages (in category '*Tools') ----- - browseLocalSendersOfMessages - "Present a menu of the currently selected message, as well as all - messages sent by it. Open a message set browser of all implementors - of the message chosen in or below the selected class" - - self getSelectorAndSendQuery: #browseAllCallsOn:localTo: - to: self systemNavigation - with: { self selectedClass }! Item was removed: - ----- Method: StringHolder>>browseMessages (in category '*Tools') ----- - browseMessages - "Present a menu of all messages sent by the currently selected message. - Open a message set browser of all implementors of the message chosen." - - self getSelectorAndSendQuery: #browseAllImplementorsOf:requestor: to: self with: #(modelMenu).! Item was removed: - ----- Method: StringHolder>>browseMethodFull (in category '*Tools') ----- - browseMethodFull - "Create and schedule a full Browser and then select the current class and message." - ^ self selectedClassOrMetaClass ifNotNil: [ :cls | - self selectedMessageName - ifNotNil: [ :sel | - ToolSet browse: cls selector: sel] - ifNil: [ToolSet browseClass: cls]].! Item was removed: - ----- Method: StringHolder>>browseSenders (in category '*Tools') ----- - browseSenders - - self browseAllCallsOn: self selectedMessageName requestor: #modelMenu.! Item was removed: - ----- Method: StringHolder>>browseSendersOfMessages (in category '*Tools') ----- - browseSendersOfMessages - "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." - - self getSelectorAndSendQuery: #browseAllCallsOn:requestor: to: self with: #(modelMenu).! Item was removed: - ----- Method: StringHolder>>browseTraitUsers (in category '*Tools-traits') ----- - browseTraitUsers - - self selectedClass ifNotNil: [:classOrTrait | - classOrTrait isTrait ifTrue: [self systemNavigation browseAllUsersOfTrait: classOrTrait]] - ! Item was removed: - ----- Method: StringHolder>>browseUnusedMethods (in category '*Tools') ----- - browseUnusedMethods - | classes unsent messageList cls | - (cls := self selectedClass) - ifNil: [^ self]. - classes := Array with: cls with: cls class. - unsent := Set new. - classes - do: [:c | unsent addAll: c selectors]. - unsent := self systemNavigation allUnSentMessagesIn: unsent. - messageList := OrderedCollection new. - classes - do: [:c | (c selectors - select: [:s | unsent includes: s]) sort - do: [:sel | messageList add: c name , ' ' , sel]]. - self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , cls name! Item was removed: - ----- Method: StringHolder>>browseVariableAssignments (in category '*Tools-traits') ----- - browseVariableAssignments - | cls | - cls := self selectedClassOrMetaClass. - (cls notNil and: [ cls isTrait not ]) ifTrue: [ self systemNavigation browseVariableAssignments: cls ]! Item was removed: - ----- Method: StringHolder>>browseVariableReferences (in category '*Tools-traits') ----- - browseVariableReferences - | cls | - cls := self selectedClassOrMetaClass. - (cls notNil and: [cls isTrait not]) - ifTrue: [self systemNavigation browseVariableReferences: cls]! Item was removed: - ----- Method: StringHolder>>browseVersions (in category '*Tools') ----- - browseVersions - "Create and schedule a Versions Browser, showing all versions of the - currently selected message. Answer the browser or nil." - ^ self classCommentIndicated - ifTrue: [ClassCommentVersionsBrowser browseCommentOf: self selectedClass] - ifFalse: [self selectedMessageName ifNotNil: - [:selector | - ToolSet browseVersionsOf: self selectedClassOrMetaClass selector: selector]]! Item was removed: - ----- Method: StringHolder>>classListKey:from: (in category '*Tools') ----- - classListKey: aChar from: view - "Respond to a Command key. I am a model with a list of classes and a - code pane, and I also have a listView that has a list of methods. The - view knows how to get the list and selection." - - aChar == $f ifTrue: [^ self findMethod]. - aChar == $r ifTrue: [^ self browseVariableReferences]. - aChar == $a ifTrue: [^ self browseVariableAssignments]. - aChar == $h ifTrue: [^ self spawnHierarchy]. - aChar == $x ifTrue: [^ self removeClass]. - ^ self messageListKey: aChar from: view! Item was removed: - ----- Method: StringHolder>>codePaneMenu:shifted: (in category '*Tools-code pane menu') ----- - codePaneMenu: aMenu shifted: shifted - ^ self menu: aMenu for: #(codePaneMenu codePaneMenuShifted:) shifted: shifted - ! Item was removed: - ----- Method: StringHolder>>codePaneMenuHook:shifted: (in category '*Tools-pluggable menus - hooks') ----- - codePaneMenuHook: aMenu shifted: aBoolean - <codePaneMenu> - <menuPriority: 400> - ^ self menuHook: aMenu named: #codePaneMenu shifted: aBoolean. - ! Item was removed: - ----- Method: StringHolder>>codeTextMorph (in category '*Tools') ----- - codeTextMorph - "Find a Morphic text pane that displays the contents of the receiver. Note that this is a hack only and violates the original idea of the model-view pattern. Using this selector in your model will likely break compatibility with other UI frameworks such as MVC. Usually, the communication should come from the view instead, e.g., via a pluggable selector." - - | textPane | - textPane := self codeTextPane. - ^ textPane isMorph ifTrue: [textPane]! Item was removed: - ----- Method: StringHolder>>codeTextPane (in category '*Tools') ----- - codeTextPane - "Find a text pane that displays the contents of the receiver. Note that this is a hack only and violates the original idea of the model-view pattern. Usually, the communication should come from the view instead, e.g., via a pluggable selector." - - ^ self anyTextPaneWithSelector: #contents! Item was removed: - ----- Method: StringHolder>>contents:notifying: (in category '*Tools-code pane menu') ----- - contents: aString notifying: aController - "Accept text" - ^self acceptContents: aString! Item was removed: - ----- Method: StringHolder>>copyName (in category '*Tools') ----- - copyName - "Copy the current selector to the clipboard" - | selector | - (selector := self selectedMessageName) ifNotNil: - [Clipboard clipboardText: selector asString asText]! Item was removed: - ----- Method: StringHolder>>copyReference (in category '*Tools') ----- - copyReference - "Copy the selected selector to the clipboard" - self selectedMessageName ifNotNil: - [ : selector | Clipboard clipboardText: - (self selectedClassOrMetaClass - ifNil: [ selector asString ] - ifNotNil: [ : cls | (cls >> selector) reference ]) ]! Item was removed: - ----- Method: StringHolder>>copySelector (in category '*Tools') ----- - copySelector - "Copy the selected selector to the clipboard" - - | selector | - (selector := self selectedMessageName) ifNotNil: - [Clipboard clipboardText: selector asString]! Item was removed: - ----- Method: StringHolder>>fileOutAllMessages (in category '*Tools') ----- - fileOutAllMessages - "Put a description of the all the message list on a file." - - FileStream - writeSourceCodeFrom: - (String new: 16000 streamContents: [:str | - self messageList do: [:e | - e actualClass printMethodChunk: e methodSymbol withPreamble: true - on: str moveSource: false toFile: 0]]) - baseName: (self messageListSelectorTitle replaceAll: Character space with: $_) isSt: true useHtml: false! Item was removed: - ----- Method: StringHolder>>fileOutMessage (in category '*Tools') ----- - fileOutMessage - "Put a description of the selected message on a file. - If no message is selected, put a description of ALL the message list." - - self selectedMessageName - ifNil: - [self fileOutAllMessages] - ifNotNil: - [Cursor write showWhile: - [self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]! Item was removed: - ----- Method: StringHolder>>findMethodInChangeSets (in category '*Tools') ----- - findMethodInChangeSets - "Find and open a changeSet containing the current method." - - | aName | - (aName := self selectedMessageName) ifNotNil: [ - ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass - selector: aName]! Item was removed: - ----- Method: StringHolder>>inspectInstances (in category '*Tools') ----- - inspectInstances - "Inspect all instances of the selected class." - - | myClass | - (myClass := self selectedClassOrMetaClass) ifNotNil: - [myClass theNonMetaClass inspectAllInstances]. - ! Item was removed: - ----- Method: StringHolder>>inspectSubInstances (in category '*Tools') ----- - inspectSubInstances - "Inspect all instances of the selected class and all its subclasses" - - | aClass | - (aClass := self selectedClassOrMetaClass) ifNotNil: [ - aClass theNonMetaClass inspectSubInstances]. - ! Item was removed: - ----- Method: StringHolder>>mainCodePaneMenu:shifted: (in category '*Tools-code pane menu') ----- - mainCodePaneMenu: aMenu shifted: shifted - <codePaneMenu> - "Fill in the given menu with additional items. The menu is prepoulated with the 'standard' text commands that the editor supports. Note that unless we override perform:orSendTo:, the editor will respond to all menu items in a text pane" - ^ self class codePaneMenu: aMenu shifted: shifted. - ! Item was removed: - ----- Method: StringHolder>>menuHook:named:shifted: (in category '*Tools-code pane menu') ----- - menuHook: aMenu named: aSymbol shifted: aBool - "Provide a hook for supplemental menu items. Answer the appropriately-enhanced menu." - ^ aMenu! Item was removed: - ----- Method: StringHolder>>messageList (in category '*Tools') ----- - messageList - ^Array new! Item was removed: - ----- Method: StringHolder>>messageListKey:from: (in category '*Tools') ----- - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ self toggleDiffing]. - - aChar == $m ifTrue: [^ self browseImplementors]. - aChar == $n ifTrue: [^ self browseSenders]. - - "The following require a class selection" - sel := self selectedMessageName. - (class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. - aChar == $b ifTrue: [^ ToolSet browse: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseClassHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - "The following require a method selection" - sel ifNotNil: - [aChar == $o ifTrue: [^ self fileOutMessage]. - aChar == $c ifTrue: [^ self copySelector]. - aChar == $C ifTrue: [^ self copyReference]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $x ifTrue: [^ self removeMessage]]. - - ^ self arrowKey: aChar from: view! Item was removed: - ----- Method: StringHolder>>messageListSelectorTitle (in category '*Tools') ----- - messageListSelectorTitle - | selector aString aStamp aSize | - - (selector := self selectedMessageName) - ifNil: - [aSize := self messageList size. - ^ (aSize = 0 ifTrue: ['no'] ifFalse: [aSize printString]), ' message', (aSize = 1 ifTrue: [''] ifFalse: ['s'])] - ifNotNil: - [Preferences timeStampsInMenuTitles - ifFalse: [^ nil]. - aString := selector truncateWithElipsisTo: 28. - ^ (aStamp := self timeStamp) size > 0 - ifTrue: - [aString, String cr, aStamp] - ifFalse: - [aString]]! Item was removed: - ----- Method: StringHolder>>methodHierarchy (in category '*Tools') ----- - methodHierarchy - "Create and schedule a method browser on the hierarchy of implementors." - - self systemNavigation - methodHierarchyBrowserForClass: self selectedClassOrMetaClass - selector: self selectedMessageName - ! Item was removed: - ----- Method: StringHolder>>offerDurableMenuFrom:shifted: (in category '*Tools') ----- - offerDurableMenuFrom: menuRetriever shifted: aBoolean - "Pop up (morphic only) a menu whose target is the receiver and whose contents are provided by sending the menuRetriever to the receiver. The menuRetriever takes two arguments: a menu, and a boolean representing the shift state; put a stay-up item at the top of the menu." - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu addStayUpItem. - self perform: menuRetriever with: aMenu with: aBoolean. - aMenu popUpInWorld! Item was removed: - ----- Method: StringHolder>>offerMenuFrom:shifted: (in category '*Tools') ----- - offerMenuFrom: menuRetriever shifted: aBoolean - "Pop up a menu whose target is the receiver and whose contents are provided - by sending the menuRetriever to the receiver. The menuRetriever takes two - arguments: a menu, and a boolean representing the shift state." - - Project current offerMenu: menuRetriever from: self shifted: aBoolean - ! Item was removed: - ----- Method: StringHolder>>openLabel: (in category '*Tools') ----- - openLabel: aString - "Create a standard system view of the model, me, a StringHolder and open it. If in mvc, terminate the active controller so that the new window will immediately be activated." - ^ToolBuilder open: self label: aString! Item was removed: - ----- Method: StringHolder>>printOutMessage (in category '*Tools') ----- - printOutMessage - "Write a file with the text of the selected message, for printing by a web browser" - - self selectedMessageName ifNotNil: [ - self selectedClassOrMetaClass fileOutMethod: self selectedMessageName - asHtml: true]! Item was removed: - ----- Method: StringHolder>>removeFromCurrentChanges (in category '*Tools') ----- - removeFromCurrentChanges - "Tell the changes mgr to forget that the current msg was changed." - - ChangeSet current removeSelectorChanges: self selectedMessageName - class: self selectedClassOrMetaClass. - self changed: #annotation! Item was removed: - ----- Method: StringHolder>>revertAndForget (in category '*Tools') ----- - revertAndForget - "Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed. Danger!! Use only if you really know what you're doing!!" - - self okToChange ifFalse: [^ self]. - self revertToPreviousVersion. - self removeFromCurrentChanges. - self contentsChanged - ! Item was removed: - ----- Method: StringHolder>>revertToPreviousVersion (in category '*Tools') ----- - revertToPreviousVersion - "Revert to the previous version of the current method" - | aClass aSelector changeRecords | - self okToChange ifFalse: [^ self]. - aClass := self selectedClassOrMetaClass. - aClass ifNil: [^ self changed: #flash]. - aSelector := self selectedMessageName. - changeRecords := aClass changeRecordsAt: aSelector. - (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash. ^ Beeper beep]. - changeRecords second fileIn. - self contentsChanged - ! Item was removed: - ----- Method: StringHolder>>selectMessageAndEvaluate: (in category '*Tools') ----- - selectMessageAndEvaluate: aBlock - "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any" - - | selector method | - (selector := self selectedMessageName) ifNil: [^ self]. - method := (self selectedClassOrMetaClass ifNil: [^aBlock value: selector]) - compiledMethodAt: selector - ifAbsent: []. - method isNil ifTrue: [^aBlock value: selector]. - ^self withSelectorAndMessagesIn: method evaluate: aBlock! Item was removed: - ----- Method: StringHolder>>showBytecodes (in category '*Tools-code pane menu') ----- - showBytecodes - "We don't know how to do this" - - ^ self changed: #flash! Item was removed: - ----- Method: StringHolder>>timeStamp (in category '*Tools') ----- - timeStamp - "Answer the time stamp for the chosen class and method, if any, else an empty string" - - | selector aMethod | - (selector := self selectedMessageName) ifNotNil: - [self selectedClassOrMetaClass - ifNil: - [^ String new] - ifNotNil: - [aMethod := self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [nil]. - aMethod ifNotNil: [^ aMethod timeStamp]]]. - ^ String new! Item was removed: - ----- Method: StringHolder>>wantsAnnotationPane (in category '*Tools-optional panes') ----- - wantsAnnotationPane - "Answer whether the receiver, seen in some browser window, would like to have the so-called annotationpane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary." - - ^ Preferences annotationPanes! Item was removed: - ----- Method: StringHolder>>wantsOptionalButtons (in category '*Tools-optional panes') ----- - wantsOptionalButtons - "Answer whether the receiver, seen in some browser window, would like to have the so-called optional button pane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary." - - ^ Preferences optionalButtons! Item was removed: - ----- Method: StringHolder>>withSelectorAndMessagesIn:evaluate: (in category '*Tools') ----- - withSelectorAndMessagesIn: aCompiledMethod evaluate: aBlock - "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any" - - | selectorOrNil messages | - selectorOrNil := aCompiledMethod selector. - messages := aCompiledMethod anyAndAllMessages. - messages remove: selectorOrNil ifAbsent: ["do nothing"]. - messages ifEmpty: "If only one item, there is no choice" - [^selectorOrNil ifNotNil: [aBlock value: selectorOrNil]]. - self systemNavigation - showMenuOf: messages - withFirstItem: selectorOrNil - ifChosenDo: aBlock! Item was removed: - ----- Method: Symbol>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Symbol'! Item was removed: - StringHolder subclass: #SyntaxError - instanceVariableNames: 'class selector debugger notification' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !SyntaxError commentStamp: '<historical>' prior: 0! - I represent syntax error report for syntax errors encountered when filing in class descriptions from a non-interactive source such as an external file. As a StringHolder, the string to be viewed is the method code or expression containing the error. - - The user may fix the error and accept the method to continue the fileIn. - ! Item was removed: - ----- Method: SyntaxError class>>open: (in category 'instance creation') ----- - open: aSyntaxErrorNotification - - ^ ToolBuilder default openDebugger: (self new setNotification: aSyntaxErrorNotification; yourself)! Item was removed: - ----- Method: SyntaxError>>aboutToStyle: (in category 'text menu support') ----- - aboutToStyle: aStyler - - aStyler - classOrMetaClass: self selectedClassOrMetaClass; - environment: notification environment; - context: notification context; - parseAMethod: notification doitFlag not. - ^ true! Item was removed: - ----- Method: SyntaxError>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - - | windowSpec listSpec textSpec | - windowSpec := builder pluggableWindowSpec new - model: self; - label: 'Syntax Error'; - children: OrderedCollection new. - - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #list; - getIndex: #listIndex; - setIndex: nil; - menu: #listMenu:; - frame: (0 at 0 corner: 1 at 0.15). - windowSpec children add: listSpec. - - textSpec := builder pluggableCodePaneSpec new. - textSpec - model: self; - getText: #contents; - setText: #contents:notifying:; - selection: #contentsSelection; - menu: #codePaneMenu:shifted:; - frame: (0 at 0.15 corner: 1 at 1). - windowSpec children add: textSpec. - - ^ builder build: windowSpec! Item was removed: - ----- Method: SyntaxError>>contents:notifying: (in category 'other') ----- - contents: aString notifying: aController - "Accept the code editions if syntax is correct. - Then let the notification signalerContext proceed and restart compilation with these newSource." - - "In case of failure, return false so as to not accept the edits" - notification reparse: aString notifying: aController ifFail: [^false]. - - "else accept edits and proceed" - aController hasUnacceptedEdits: false. - self proceed! Item was removed: - ----- Method: SyntaxError>>contentsSelection (in category 'accessing') ----- - contentsSelection - - ^ notification ifNil: [1 to: 0] ifNotNil: [self errorMessageInterval]! Item was removed: - ----- Method: SyntaxError>>debug (in category 'menu') ----- - debug - "Show the stack of the process leading to this syntax editor, typically showing the stack of the compiler as called from fileIn." - - debugger openFullNoSuspendLabel: 'Stack of the Syntax Error'. - Smalltalk isMorphic ifFalse: [Processor terminateActive]. - ! Item was removed: - ----- Method: SyntaxError>>debugger (in category 'accessing') ----- - debugger - - ^ debugger! Item was removed: - ----- Method: SyntaxError>>errorMessageInterval (in category 'text menu support') ----- - errorMessageInterval - "To understand this format, see Parser >> #notify:at:." - - ^ notification location - to: notification location - + '"' size - + notification errorMessage size - 1 - + ' ->"' size! Item was removed: - ----- Method: SyntaxError>>initialExtent (in category 'initialize-release') ----- - initialExtent - - ^ 380 at 220! Item was removed: - ----- Method: SyntaxError>>list (in category 'message list') ----- - list - "Answer an array of one element made up of the class name and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver." - - ^ Array with: (class name, ' ', (selector ifNil: ['<none>'])) - ! Item was removed: - ----- Method: SyntaxError>>listIndex (in category 'message list') ----- - listIndex - "There is always exactly one element in my list and it is always selected." - - ^ 1 - ! Item was removed: - ----- Method: SyntaxError>>listMenu: (in category 'menu') ----- - listMenu: aMenu - - ^ aMenu labels: - 'proceed - debug calling process - browse full' - lines: #() - selections: #(proceed debug browseMethodFull) - ! Item was removed: - ----- Method: SyntaxError>>proceed (in category 'menu') ----- - proceed - "The user has has edited and presumably fixed the syntax error and the filein can now proceed. The active process usually suspends (or terminates) after this call." - - [debugger proceed] - ensure: [self changed: #close].! Item was removed: - ----- Method: SyntaxError>>release (in category 'initialize-release') ----- - release - debugger ifNotNil: - [debugger interruptedProcess ifNotNil: - [:p | p isTerminated ifFalse: - [p terminate]]].! Item was removed: - ----- Method: SyntaxError>>selectedClass (in category 'text menu support') ----- - selectedClass - "Answer the class in which the syntax error occurred." - - ^ class - ! Item was removed: - ----- Method: SyntaxError>>selectedClassOrMetaClass (in category 'text menu support') ----- - selectedClassOrMetaClass - "Answer the class of the method being compiled." - - ^ class - ! Item was removed: - ----- Method: SyntaxError>>selectedMessageName (in category 'text menu support') ----- - selectedMessageName - "Answer the selector of the method being compiled." - - ^ selector - ! Item was removed: - ----- Method: SyntaxError>>setNotification: (in category 'accessing') ----- - setNotification: aSyntaxErrorNotification - - | types printables badChar code | - notification := aSyntaxErrorNotification. - class := aSyntaxErrorNotification errorClass. - - debugger := Project current debuggerClass new. - debugger context: aSyntaxErrorNotification signalerContext. - - code := aSyntaxErrorNotification errorCode. - selector := class newParser parseSelector: code. - types := Scanner classPool at: #TypeTable. "dictionary" - printables := '!!@#$%&*-_=+<>{}?/\,·£¢§¶ªº–—“‘”’…Úæگ׿«»`~`' asSet. - badChar := code detect: [:aChar | (types at: aChar asciiValue ifAbsent: [#xLetter]) == #xBinary and: [ - (printables includes: aChar) not]] ifNone: [nil]. - contents := badChar - ifNil: [code] - ifNotNil: ['<<<This string contains a character (ascii value ', - badChar asciiValue printString, - ') that is not normally used in code>>> ', code]. - - self changed: #contentsSelection.! Item was removed: - AppRegistry subclass: #SystemBrowser - instanceVariableNames: '' - classVariableNames: 'BrowseWithDragNDrop BrowseWithPrettyPrint' - poolDictionaries: '' - category: 'Tools-Base'! - - !SystemBrowser commentStamp: '<historical>' prior: 0! - This is the AppRegistry class for class browsing! Item was removed: - ----- Method: SystemBrowser class>>addRegistryMenuItemsTo:inAccountOf: (in category 'registration') ----- - addRegistryMenuItemsTo: aMenu inAccountOf: aBrowser - "Add some useful options related Browser registry to the - browsers windows menu" - aMenu addLine; - add: 'Register this Browser as default' - target: [self default: aBrowser class] - action: #value; - add: 'Choose new default Browser' - target: self - action: #askForDefault! Item was removed: - ----- Method: SystemBrowser class>>browseWithDragNDrop (in category 'preferences') ----- - browseWithDragNDrop - <preference: 'Browse with drag ''n'' drop' category: 'browsing' description: 'If true, new browsers will open with drag & drop functionality (only in Morphic)' type: #Boolean> - ^ BrowseWithDragNDrop ifNil: [false].! Item was removed: - ----- Method: SystemBrowser class>>browseWithDragNDrop: (in category 'preferences') ----- - browseWithDragNDrop: aBoolean - BrowseWithDragNDrop := aBoolean.! Item was removed: - ----- Method: SystemBrowser class>>browseWithPrettyPrint (in category 'preferences') ----- - browseWithPrettyPrint - <preference: 'Browse with pretty-print' category: 'browsing' description: 'If true, browsers will automatically format their contents' type: #Boolean> - ^ BrowseWithPrettyPrint ifNil: [false].! Item was removed: - ----- Method: SystemBrowser class>>browseWithPrettyPrint: (in category 'preferences') ----- - browseWithPrettyPrint: aBoolean - BrowseWithPrettyPrint := aBoolean.! Item was removed: - ----- Method: SystemBrowser class>>browserShowsPackagePane (in category 'preferences') ----- - browserShowsPackagePane - <preference: 'Browser shows package pane' category: 'browsing' description: 'If true, then the various ''browse full'' and ''browse it'' commands (usually invoked via cmd-b) will open a Package Browser rather than a System Browser. The Package Browser includes a package pane which groups system categories into packages based on the initial portion of their category name.' type: #Boolean> - ^ SystemNavigation default browserClass == PackagePaneBrowser.! Item was removed: - ----- Method: SystemBrowser class>>browserShowsPackagePane: (in category 'preferences') ----- - browserShowsPackagePane: aBooleanOrNil - | theOtherOne | - self registeredClasses size = 2 - ifTrue: [theOtherOne := (self registeredClasses copyWithout: PackagePaneBrowser) first] - ifFalse: [theOtherOne := nil]. - aBooleanOrNil == true - ifTrue: [self default: PackagePaneBrowser] - ifFalse: [self default: theOtherOne]. - SystemNavigation default browserClass: self default.! Item was removed: - ----- Method: SystemBrowser class>>defaultOpenBrowser (in category 'instance creation') ----- - defaultOpenBrowser - ^self default openBrowser! Item was removed: - ----- Method: SystemNavigation>>allUsersOfTrait: (in category '*tools-traits') ----- - allUsersOfTrait: aTrait - - ^ aTrait users collect: [:class | MethodReference class: class selector: #Definition]! Item was removed: - ----- Method: SystemNavigation>>browseAllUsersOfTrait: (in category '*tools-traits') ----- - browseAllUsersOfTrait: aTrait - - ^ self - browseMessageList: [self allUsersOfTrait: aTrait] - name: 'Users of ', aTrait name! Item was removed: - ----- Method: SystemNavigation>>browserClass (in category '*tools-browser') ----- - browserClass - browserClass ifNil: [browserClass := self defaultBrowserClass]. - ^browserClass! Item was removed: - ----- Method: SystemNavigation>>browserClass: (in category '*tools-browser') ----- - browserClass: aBrowserClass - browserClass := aBrowserClass! Item was removed: - ----- Method: SystemNavigation>>defaultBrowserClass (in category '*tools-browser') ----- - defaultBrowserClass - ^SystemBrowser default! Item was removed: - ----- Method: SystemNavigation>>defaultHierarchyBrowserClass (in category '*tools-browser') ----- - defaultHierarchyBrowserClass - ^self class environment at: #HierarchyBrowser ifAbsent:[]! Item was removed: - ----- Method: SystemNavigation>>hierarchyBrowserClass (in category '*tools-browser') ----- - hierarchyBrowserClass - hierarchyBrowserClass ifNil: [hierarchyBrowserClass := self defaultHierarchyBrowserClass]. - ^hierarchyBrowserClass! Item was removed: - ----- Method: SystemNavigation>>hierarchyBrowserClass: (in category '*tools-browser') ----- - hierarchyBrowserClass: aBrowserClass - hierarchyBrowserClass := aBrowserClass! Item was removed: - ----- Method: TTCFont>>browseAllGlyphsScaledToDisplay (in category '*Tools-Browsing') ----- - browseAllGlyphsScaledToDisplay - "Overwritten to support not-yet-registered fonts, e.g. through the FontImporterTool." - - ^ self isInstalled - ifTrue: [super browseAllGlyphsScaledToDisplay] - ifFalse: [self browseAllGlyphs]! Item was removed: - ----- Method: TTCFont>>browseGlyphsByCategoryOf:select:label: (in category '*Tools-Browsing') ----- - browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil - "Overwritten to speed up browsing for remote fonts. We have to compose a paragraph with a lot of new glyphs in a paragraph ... even though we will not render all at the same time." - - ttcDescription cacheGlyphDataDuring: [ - ^ super browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil].! Item was removed: - ----- Method: TTCFont>>browseGlyphsOf:select:label: (in category '*Tools-Browsing') ----- - browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil - "Overwritten to speed up browsing for remote fonts. We have to compose a paragraph with a lot of new glyphs in a paragraph ... even though we will not render all at the same time." - - ttcDescription cacheGlyphDataDuring: [ - ^ super browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil].! Item was removed: - ----- Method: Text>>addAttributesForDeprecation (in category '*Tools-attributes') ----- - addAttributesForDeprecation - "Add text attributes to the receiver so that clients will recognize the underlying artifact (e.g., class or method) as deprecated." - - ((UserInterfaceTheme current get: #deprecatedMessageAttributes for: #CodeHolder) - ifNil: [{TextColor gray. TextEmphasis struckOut}]) - do: [:textAttribute | self addAttribute: textAttribute].! Item was removed: - ----- Method: Text>>askIfAddStyle:req: (in category '*Tools-attributes') ----- - askIfAddStyle: priorMethod req: requestor - "Ask the user if we have a complex style (i.e. bold) for the first time" - | tell answ old | - (SystemBrowser browseWithPrettyPrint) 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 := (Project uiManager - chooseOptionFrom: #('Save method with style' 'Save method simply') - title: tell). - answ = 2 ifTrue: [^ self asString]]! Item was removed: - ----- Method: Text>>canonicalArgumentName (in category '*Tools-Debugger') ----- - canonicalArgumentName - ^ 'Text'! Item was removed: - ----- Method: TextEditor>>saveContentsInFile (in category '*Tools-file out') ----- - saveContentsInFile - "Save the receiver's contents string to a file, which usually prompts the user for a file name." - - self paragraph text string - ifEmpty: [self inform: 'Nothing to save.'] - ifNotEmpty: [:stringToSave | - (self model saveContents: stringToSave accessMode: #create) - ifTrue: [ - self flag: #discuss. "mt: Is this correct? Having unaccepted contents means that the model does not know about it. Do we assume that the model will also keep track of the stringToSave?" - self morph hasUnacceptedEdits: false]].! Item was removed: - ----- Method: TextStyle class>>browseAllStyles (in category '*Tools-Browsing') ----- - browseAllStyles - - ^ self browseAllStylesAtPointSize: self defaultFont pointSize! Item was removed: - ----- Method: TextStyle class>>browseAllStylesAtPointSize: (in category '*Tools-Browsing') ----- - browseAllStylesAtPointSize: pointSize - " - self browseAllStylesAtPointSize: 24.0 - " - ^ self browseAllStylesAtPointSize: pointSize sample: 'HelloSqueak' ! Item was removed: - ----- Method: TextStyle class>>browseAllStylesAtPointSize:sample: (in category '*Tools-Browsing') ----- - browseAllStylesAtPointSize: pointSize sample: aString - " - self browseAllStylesAtPointSize: 24.0 sample: 'HelloSqueak' - " - - (Text streamContents: [:stream | | allStyles | - allStyles := self actualTextStyles sorted: [:a :b | - (a isTTCStyle and: [b isTTCStyle not]) - or: [a isTTCStyle = b isTTCStyle and: [a defaultFamilyName <= b defaultFamilyName]]]. - - "1) Combine all side-by-side to be able to compare ascent/descent/baseline." - allStyles do: [:style | - stream nextPutAll: (aString asText addAttribute: (TextFontReference toFont: (style defaultFont asPointSize: pointSize)); yourself)]. - stream cr; cr. - - "2) Show one per line. Be sure to also set the font for the line break to get the correct line height." - allStyles do: [:style | stream nextPutAll: ( - ('{1} {2}\' withCRs asText format: {aString. style defaultFamilyName asText addAttribute: (PluggableTextAttribute evalBlock: [style explore]); yourself}) addAttribute: (TextFontReference toFont: (style defaultFont asPointSize: pointSize)); yourself)] - - ]) editWithLabel: 'All known fonts/styles'! Item was removed: - ----- Method: TextStyle>>chooseExtraGap (in category '*Tools-Browsing') ----- - chooseExtraGap - " - TextStyle defaultFixed chooseExtraGap. - " - | sampleFont answer | - self isTTCStyle ifFalse: [^ self]. - sampleFont := self defaultFont. - - answer := Project uiManager - request: ('Change extra leading for font\{1}.\Reset to default via non-number.' translated withCRs asText format: {self defaultFamilyName asText allBold}) - initialAnswer: sampleFont extraLineGap asString. - (answer isNil or: [answer isEmpty]) ifTrue: [^ self]. - answer := [answer asNumber] on: NumberParserError do: [nil]. - - sampleFont extraLineGap: answer. - UserInterfaceTheme current basicApply.! Item was removed: - ----- Method: TextStyle>>chooseExtraScale (in category '*Tools-Browsing') ----- - chooseExtraScale - " - TextStyle defaultFixed chooseExtraScale. - " - | sampleFont answer | - self isTTCStyle ifFalse: [^ self]. - sampleFont := self defaultFont. - - answer := Project uiManager - request: ('Change extra scale for glyphs of font\{1}.\Reset to default via non-number.' translated withCRs asText format: {self defaultFamilyName asText allBold}) - initialAnswer: sampleFont extraGlyphScale asString. - (answer isNil or: [answer isEmpty]) ifTrue: [^ self]. - answer := [answer asNumber] on: NumberParserError do: [nil]. - - sampleFont extraGlyphScale: answer. - UserInterfaceTheme current basicApply.! Item was removed: - ----- Method: TheWorldMenu>>browseRecentLog (in category '*Tools') ----- - browseRecentLog - ChangeList browseRecentLog! Item was removed: - ----- Method: TheWorldMenu>>openChangeSorter1 (in category '*Tools') ----- - openChangeSorter1 - - ToolBuilder open: ChangeSorter new! Item was removed: - ----- Method: TheWorldMenu>>openChangeSorter2 (in category '*Tools') ----- - openChangeSorter2 - - ToolBuilder open: DualChangeSorter new! Item was removed: - ----- Method: TheWorldMenu>>openMessageNames (in category '*Tools') ----- - openMessageNames - "Bring a MessageNames tool to the front" - - MessageNames openMessageNames! Item was removed: - ----- Method: TheWorldMenu>>openProcessBrowser (in category '*Tools') ----- - openProcessBrowser - ProcessBrowser open! Item was removed: - ----- Method: TheWorldMenu>>openSelectorBrowser (in category '*Tools') ----- - openSelectorBrowser - - ToolBuilder open: SelectorBrowser new! Item was removed: - ----- Method: TheWorldMenu>>startThenBrowseMessageTally (in category '*Tools') ----- - startThenBrowseMessageTally - (self confirm: 'MessageTally will start now, - and stop when the cursor goes - to the top of the screen') - ifTrue: [ | world | - world := Project current world. - TimeProfileBrowser - onBlock: [[Sensor peekPosition y > 10] - whileTrue: [world doOneCycle]]]! Item was removed: - MessageSet subclass: #TimeProfileBrowser - instanceVariableNames: 'block tally methodReferences' - classVariableNames: 'TextMenu' - poolDictionaries: '' - category: 'Tools-Debugger'! - - !TimeProfileBrowser commentStamp: '<historical>' prior: 0! - A TimeProfileBrowser is a browser visualizing the runtime profile of an executed Smalltalk block. It is useful for finding performance bottlenecks in code. When optimizing code it can - be hard to know what methods actually constitute the bulk of the execution time. Is it a few - methods that take very long time to execute or is it perhaps a single method that gets executed a thousand times? - - The block is first spied on using a MessageTally instance (which has even more funtionality than used by the TimeProfileBrowser) which samples the block during it's execution and collects the amount of time approximately spent in the methods executed. Then the methods are shown in the browser with their relative execution time in percent. - - Example: - TimeProfileBrowser onBlock: [20 timesRepeat: [Transcript show: 100 factorial printString]] - ! Item was removed: - ----- Method: TimeProfileBrowser class>>onBlock: (in category 'instance creation') ----- - onBlock: block - "Open a profile browser on the given block, thereby running the block and - collecting the message tally." - "TimeProfileBrowser onBlock: [20 timesRepeat: - [Transcript show: 100 factorial printString]]" - - | inst result | - inst := self new. - result := inst runBlock: block. - self open: inst name: 'Time Profile'. - ^ result! Item was removed: - ----- Method: TimeProfileBrowser class>>parse:toClassAndSelector: (in category 'utilities') ----- - parse: aString toClassAndSelector: csBlock - "Try to create a MethodReference from a line returned by MessageTally. Set both class and selector to nil if the string doesn't have the given format." - - | stream className class selector | - stream := aString readStream. - "Skip percentages and timing data." - stream - skipTo: $}; - skipSeparators. - (stream peekFor: $[) ifTrue: [ "Skip block markers." - stream upToAnyOf: CharacterSet separators ]. - className := stream upToAnyOf: '(>'. - - stream atEnd ifTrue: [ ^ csBlock value: nil value: nil ]. - stream last == $( ifTrue: [ "Method is defined in a super class" - className := stream upTo: $). - (stream peekFor: $>) ifFalse: [ ^ csBlock value: nil value: nil ] ]. - (stream peekFor: $>) ifFalse: [ ^ csBlock value: nil value: nil ]. - selector := stream upToEnd. - - self flag: #environments. "missing information about the class environment" - (class := Smalltalk classNamed: className) ifNil: [^ csBlock value: nil value: nil]. - (selector := Symbol lookup: selector) ifNil: [^ csBlock value: nil value: nil]. - ^ csBlock value: class value: selector! Item was removed: - ----- Method: TimeProfileBrowser class>>spyOn: (in category 'instance creation') ----- - spyOn: block - "Open a profile browser on the given block, thereby running the block and - collecting the message tally." - "TimeProfileBrowser spyOn: [20 timesRepeat: - [Transcript show: 100 factorial printString]]" - - ^self onBlock: block! Item was removed: - ----- Method: TimeProfileBrowser class>>spyOnProcess:forMilliseconds: (in category 'instance creation') ----- - spyOnProcess: aProcess forMilliseconds: msecDuration - "Run aProcess for msecDuration milliseconds, then open a TimeProfileBrowser on the results." - - "| p | - p := [100000 timesRepeat: [3.14159 printString]] fork. - (Delay forMilliseconds: 100) wait. - TimeProfileBrowser spyOnProcess: p forMilliseconds: 1000" - - | inst | - inst := self new. - inst runProcess: aProcess forMilliseconds: msecDuration pollingEvery: MessageTally defaultPollPeriod. - self open: inst name: (String streamContents: [ :s | s nextPutAll: 'Time Profile for '; print: msecDuration; nextPutAll: ' msec' ]). - ^ inst! Item was removed: - ----- Method: TimeProfileBrowser>>formattedLabel:forSelector:inClass: (in category 'as yet unclassified') ----- - formattedLabel: aString forSelector: aSymbol inClass: aClass - - ^ aClass - ifNil: [aString] - ifNotNil: [super formattedLabel: aString forSelector: aSymbol inClass: aClass]! Item was removed: - ----- Method: TimeProfileBrowser>>hasMessageSelected (in category 'message list') ----- - hasMessageSelected - - ^super hasMessageSelected and: [ - (self methodReferences at: self messageListIndex) notNil ]! Item was removed: - ----- Method: TimeProfileBrowser>>initializeMessageList: (in category 'private') ----- - initializeMessageList: anArray - messageList := anArray. - messageListIndex := 0. - contents := ''! Item was removed: - ----- Method: TimeProfileBrowser>>isModeStyleable (in category 'contents') ----- - isModeStyleable - "Ensure that only methods are styled." - - ^self selectedMessageName notNil and: [ super isModeStyleable ]! Item was removed: - ----- Method: TimeProfileBrowser>>messageHelpAt: (in category 'message list') ----- - messageHelpAt: anIndex - "Show the first n lines of the sources code of the selected message." - - | reference | - Preferences balloonHelpInMessageLists ifFalse: [^ nil]. - self messageList size < anIndex ifTrue: [^ nil]. - - reference := (self methodReferences at: anIndex) ifNil: [ ^nil ]. - reference isValid ifFalse: [ ^nil ]. - ^ self messageHelpForMethod: reference compiledMethod! Item was removed: - ----- Method: TimeProfileBrowser>>messageIconAt: (in category 'message list') ----- - messageIconAt: index - - ^nil! Item was removed: - ----- Method: TimeProfileBrowser>>messageListKey:from: (in category 'private') ----- - messageListKey: aChar from: view - "Respond to a Command key. Cmd-D means re-run block." - - aChar == $d ifTrue: [ ^Cursor execute showWhile: block ]. - ^super messageListKey: aChar from: view! Item was removed: - ----- Method: TimeProfileBrowser>>methodReferenceFrom: (in category 'private') ----- - methodReferenceFrom: aString - - ^ self class parse: aString toClassAndSelector: [:class :selector | - class ifNotNil: [MethodReference class: class selector: selector]]! Item was removed: - ----- Method: TimeProfileBrowser>>methodReferences (in category 'accessing') ----- - methodReferences - - ^methodReferences ifNil: [ - methodReferences := messageList collect: [ :each | self methodReferenceFrom: each ] ] - ! Item was removed: - ----- Method: TimeProfileBrowser>>runBlock: (in category 'private') ----- - runBlock: aBlock - ^self runBlock: aBlock pollingEvery: MessageTally defaultPollPeriod! Item was removed: - ----- Method: TimeProfileBrowser>>runBlock:pollingEvery: (in category 'private') ----- - runBlock: aBlock pollingEvery: pollPeriod - | list result | - block := MessageSend - receiver: self - selector: #runBlock:pollingEvery: - arguments: { - aBlock. - pollPeriod}. "so we can re-run it" - tally := MessageTally new. - tally - reportOtherProcesses: false; - maxClassNameSize: 1000; - maxClassPlusSelectorSize: 1000; - maxTabs: 100. - result := tally spyEvery: pollPeriod on: aBlock. - list := OrderedCollection withAll: (String streamContents: [ :s | tally report: s]) lines. - self initializeMessageList: list. - self changed: #messageList. - self changed: #messageListIndex. - ^result! Item was removed: - ----- Method: TimeProfileBrowser>>runProcess:forMilliseconds:pollingEvery: (in category 'private') ----- - runProcess: aProcess forMilliseconds: msecDuration pollingEvery: pollPeriod - | list result | - block := MessageSend - receiver: self - selector: #runProcess:forMilliseconds:pollingEvery: - arguments: { - aProcess. - msecDuration. - pollPeriod}. "so we can re-run it" - tally := MessageTally new. - tally - reportOtherProcesses: false; - maxClassNameSize: 1000; - maxClassPlusSelectorSize: 1000; - maxTabs: 100. - result := tally - spyEvery: pollPeriod - onProcess: aProcess - forMilliseconds: msecDuration. - list := OrderedCollection withAll: (String streamContents: [ :s | tally report: s]) lines. - self initializeMessageList: list. - self changed: #messageList. - self changed: #messageListIndex. - ^result! Item was removed: - ----- Method: TimeProfileBrowser>>selectedMessage (in category 'message list') ----- - selectedMessage - "Answer the source method for the currently selected message." - - self setClassAndSelectorIn: [ :class :selector | - | source | - source := (class == UndefinedObject and: [ selector == #DoIt ]) - ifTrue: [ 'DoIt', String cr, String cr, block arguments first decompile decompileString ] - ifFalse: [ class sourceMethodAt: selector ifAbsent: [ ^'Missing' ] ]. - SystemBrowser browseWithPrettyPrint ifTrue: [ - source := class prettyPrinterClass - format: source - in: class - notifying: nil - decorated: false ]. - ^source asText makeSelectorBoldIn: class ]. - ^''! Item was removed: - ----- Method: TimeProfileBrowser>>setClassAndSelectorIn: (in category 'private') ----- - setClassAndSelectorIn: csBlock - "Evaluate csBlock with the selected methodReference, or return nil if there's nothing selected." - - ^((self methodReferences at: self messageListIndex) ifNil: [ ^nil ]) - setClassAndSelectorIn: csBlock! Item was removed: - ----- Method: TimeProfileBrowser>>tally (in category 'accessing') ----- - tally - "Answer the receiver's 'tally'." - - ^tally! Item was removed: - ----- Method: TimeProfileBrowser>>tally: (in category 'accessing') ----- - tally: anObject - "Set the receiver's instance variable 'tally' to be anObject." - - tally := anObject! Item was removed: - Object subclass: #ToolIconHelp - instanceVariableNames: '' - classVariableNames: 'HelpTexts' - poolDictionaries: '' - category: 'Tools-Base'! Item was removed: - ----- Method: ToolIconHelp class>>abstract (in category 'icons') ----- - abstract - - ^ 'This method is abstract.' ! Item was removed: - ----- Method: ToolIconHelp class>>arrowDown (in category 'icons') ----- - arrowDown - - ^ 'This method is overriden by another method.'! Item was removed: - ----- Method: ToolIconHelp class>>arrowUp (in category 'icons') ----- - arrowUp - - ^ 'This method overrides a super method.'! Item was removed: - ----- Method: ToolIconHelp class>>arrowUpAndDown (in category 'icons') ----- - arrowUpAndDown - - ^ 'This method overrides and is overridden by other methods.'! Item was removed: - ----- Method: ToolIconHelp class>>blank (in category 'icons') ----- - blank - - ^ ''! Item was removed: - ----- Method: ToolIconHelp class>>breakpoint (in category 'icons') ----- - breakpoint - - ^ 'This method contains a breakpoint.'! Item was removed: - ----- Method: ToolIconHelp class>>flag (in category 'icons') ----- - flag - - ^ 'This method needs attention of some kind.' ! Item was removed: - ----- Method: ToolIconHelp class>>helpTexts (in category 'accessing') ----- - helpTexts - - ^ HelpTexts ifNil: [HelpTexts := IdentityDictionary new]! Item was removed: - ----- Method: ToolIconHelp class>>iconHelpNamed: (in category 'icons help') ----- - iconHelpNamed: aSymbol - - ^ (self respondsTo: aSymbol) - ifTrue: [self helpTexts at: aSymbol ifAbsentPut: [self perform: aSymbol]] - ifFalse: [String empty] - ! Item was removed: - ----- Method: ToolIconHelp class>>no (in category 'icons') ----- - no - - ^ 'This method should not be implemented.' ! Item was removed: - ----- Method: ToolIconHelp class>>notOverridden (in category 'icons') ----- - notOverridden - - ^ 'This method is abstract and has not been overridden.' ! Item was removed: - ----- Method: ToolIconHelp class>>primitive (in category 'icons') ----- - primitive - - ^ 'This method implements a primitive.'! Item was removed: - Object subclass: #ToolIcons - instanceVariableNames: '' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Tools-Base'! Item was removed: - ----- Method: ToolIcons class>>abstract (in category 'private') ----- - abstract - - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 165 165 165 165 165 16777215 16777215 165 165 165 165 165 16777215 16777215 165 165 16777215 2712832 2712832 16777215 165 165 165 165 165 165 165 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 165 165 165 165 165 4294967295 4284714821 4284714821 4284714821 4284714821 4284714821 4284714821 4294967295 165 165 165 16777215 4294967295 4284714821 4288074840 4288074840 4288074840 4287677545 4284714821 4294967295 16777215 165 165 16777215 4294967295 4284714821 4288074840 4287679828 4287810910 4287677545 4284714821 4294967295 16777215 165 165 16777215 4294967295 4284714821 4288074840 4287614291 4287810910 4286361178 4284714821 4294967295 16777215 165 165 16777215 4294967295 4284714821 4288074840 4287677545 4286361178 4286361178 4284714821 4294967295 16777215 165 165 165 4294967295 4284714821 4284714821 4284714821 4284714821 4284714821 4284714821 4294967295 165 165 165 165 165 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 165 165 165 165 165 165 165 16777215 2712832 2712832 16777215 165 165 165 165 165 165 165 165 165 16777215 16777215 165 165 165 165 165) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>arrowDown (in category 'private') ----- - arrowDown - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 0 0 0 0 0 0 4294967295 4284714821 4284714821 4284714821 4284714821 4294967295 0 0 0 0 0 0 4294967295 4284714821 4287614291 4287810910 4284714821 4294967295 0 0 0 0 4294967295 4294967295 4294967295 4284714821 4287679828 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 0 0 4294967295 4294967295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>arrowUp (in category 'private') ----- - arrowUp - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294967295 4294967295 0 0 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 4294967295 4294967295 4294967295 4284714821 4287679828 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 0 0 4294967295 4284714821 4287614291 4287810910 4284714821 4294967295 0 0 0 0 0 0 4294967295 4284714821 4284714821 4284714821 4284714821 4294967295 0 0 0 0 0 0 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>arrowUpAndDown (in category 'private') ----- - arrowUpAndDown - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 0 0 0 4294967295 4294967295 0 0 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 4294967295 4294967295 4294967295 4284714821 4287679828 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 4294967295 4294967295 4294967295 4284714821 4287614291 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 0 0 42949 67295 4294967295 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>blank (in category 'private') ----- - blank - ^ Form extent: 12 @ 12 depth: 8! Item was removed: - ----- Method: ToolIcons class>>blank16 (in category 'private') ----- - blank16 - ^ Form extent: 16 @ 16 depth: 8! Item was removed: - ----- Method: ToolIcons class>>breakpoint (in category 'private') ----- - breakpoint - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294156190 4294219671 4294085257 4294146939 4294140771 4294138201 4294136145 4284036633 4284036633 4284036633 4294967295 4294967295 4294219671 4294830826 4294697184 4294764005 4294156190 4294156190 4294156190 4291318347 4289820229 4284036633 4294967295 4294967295 4294085257 4294697184 4294140771 4294139229 4294136145 4294136145 4294134860 4291318347 4289820229 4284496668 4294967295 4294967295 4294140771 4294156190 4294138201 4294137173 4294136145 4294134860 4294134860 4288365876 4289820229 4284036633 4294967295 4294967295 4294139229 4294219671 4294136145 4294136145 4294134860 4294134860 4294134860 4288365876 4289820229 4283708184 4294967295 4294967295 4294137173 4294085257 4293619053 4293619053 4293619053 4293619053 4293619053 4287311645 4289820229 4283708184 4294967295 4294967295 4293473589 4292813603 4292418331 4291366414 42 90250246 4290250246 4290250246 4284036633 4289820229 4283708184 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4284036633 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4284036633 4284036633 4294967295) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>checkmark (in category 'private') ----- - checkmark - "© 2018 Icon8 - Website: https://icons8.com - License: https://creativecommons.org/licenses/by-nd/3.0/" - - ^ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: 'iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAYAAACqaXHeAAAABmJLR0QA/wD/AP+gvaeTAAAD - zUlEQVRYCe2ZT0hUQRzH561adLBDpFBBKvRH0AITtEPQHwiCgrCgIAhBJOhUdAoKOnjqUEGH - AiE6FRF1C0+RQpcKhCgwOuSf0jDDCMsSW3f6DOuDx+72nHm7+5Z5zeP73ffcmfnN7/ud35t9 - 6wrhDueAc8A54BxwDjgHnAN2OlCTSqWuVFVVveJ8Fwnb4P8DRN+DMsBfXJ/HgRRMNlj1bsTK - QqTtBeqbYWKxAeGzsKABy+/PYUR3Ih3wPO/JssgwA1RbBhOOhJlg3b2CoB4MOBwmKtDmSSlP - Bv7Ou7TNgAYp5Y08FeFvzIU329PKwntPNUtflb/iIvJaof1A+AWoRJnwov3KswpaEL8AtcWz - VzxnqG23OCnnowbhw1BbPH3nCbMd2g/EXIIm4lXfc/YrzypoR/wiVKK0yE45yNBElP4qhL+G - WsKX+6mPvEaRhANBfdBEvGTjO5ME7UpDJ+L/QG0DKP0BNTAJXIPwd1BbPH1nEb4R2g/EXIMm - 4lXpn7ZfeVbBXsQvQalLSv9Rdqj9r7WIHoXa4uk7jew6aD8QcwuaiFelf9R+5Siorq4+hPgM - NDHgPkOLhhchwnoSPc69t8TxkPHq4YNTZKjSf8PoRqF/zGQymVa6f4Wxog3x09BfqXEhRFFf - OojVD/14WmceeLqYN3Z0kuh3mJvkDJnsgMZAyLEC8XLj5/59x3iiEgzoINFC4v3kophQT8wZ - 6MfQOU+gZS2MFR0kGSbeT9zIBGI+gP5YnXOGzfJArMqZbB1JTkGdBFWfKcasuCdQ+l0GMVVc - xX5ixwsS7Y2Q6GeyDDOhjphfoBKlyzFi1sKSI7VCxKUV2gs1q19tBmkoaAIfn7dpq4e6UM8H - PXT+AWOH+oweNVwtf1XzKoGKOhUh1s3YVedMuJmkP0BfmMk5uDGqODqbaTD+W3JZDSsOlXwx - Juyk9KP8qLGr4soDCWylCiZhcIV0r39GGHc1MHfZLj3DyKoShoQQTbBsoFqG+Z6xmwnSsKzw - IkQvtwkLfNFpJ68RWHakIszwkQT3M24MlgN9BI1FPPMIT71EZAP39ZAQolGU6KD0X1L6ewiX - hrHAK3KWUprwm8pqI5/3MDZEuQWCyU2Q9D4hxLgo/rhMiFjFM1/JoCphjFtCRiFPiENCiGIX - gxCVxRbEf4KmJsyRdhNMBJQJk4YmnE2E8oAI7SdGdv0BxnkwcdAx4RuqN8HEooVb4Z//+GDj - 602s8oCwZkwYgbkb4/VAn4pexnH/1bDaJ6SUB1E6jxmP0+n0M64dnAPOAeeAc8A54BxwDlTU - gb+am3XexSy3CAAAAABJRU5ErkJggg==' readStream)! Item was removed: - ----- Method: ToolIcons class>>cleanUp: (in category 'initialize-release') ----- - cleanUp: aggressive - - aggressive ifTrue: [Icons := nil].! Item was removed: - ----- Method: ToolIcons class>>collection (in category 'private') ----- - collection - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 4294964203 4294947198 4294938953 4294947198 4294964203 0 0 0 0 0 0 0 4294946167 4294483041 4293435505 4293693782 4294945395 0 4293916398 4287874445 4285050207 4287874445 4293916398 0 4294939470 4293566834 4292777576 4291988059 4294938953 0 4287545991 4287348353 4288922521 4286558838 4287283332 0 4294946167 4293891161 4292119903 4293035852 4294945395 0 4285247331 4288988570 4288461714 4287606661 4285050207 0 4294963945 4294946426 4294938181 4294946426 4294963945 0 4287545991 4286821753 4287803784 4286031980 4287283332 0 0 0 0 0 0 0 4293785068 4287677321 4284787547 4287677321 4293785068 0 0 0 4294834926 4294238348 4293907294 4294238348 4294834926 0 0 0 0 0 0 0 4294172295 4293777015 4292988807 4293053292 4294172035 0 0 0 0 0 0 0 4293973090 4293186184 4292462206 4291672945 4293907294 0 0 0 0 0 0 0 4294172295 4293184879 4291738741 4292460898 4294172035 0 0 0 0 0 0 0 4294834924 4294238089 4293907034 4294238089 4294834924 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>exception (in category 'private') ----- - exception - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 4294371495 4293908066 4293842277 4293841507 4293775456 4293708891 4293577045 4293378633 4294371516 4294834928 0 0 4294172547 4294106220 4294040432 4294039405 4293973096 4293906533 4293576270 4293245752 4294504141 4294835187 0 4294768349 4293974633 4294634386 4294368606 4294235479 4294301290 4294236810 4293444430 4294636250 0 0 0 4294239131 4294370178 4294368870 4294102843 4294036547 4294236543 4293510488 4294437573 0 0 0 4294834665 4293973866 4294502031 4294169671 4293970487 4294170225 4293840750 4294239413 0 0 0 0 4294371762 4294172025 4294435187 4294168905 4293969724 4294169977 4293246022 4293444706 4293378916 4293246298 4293048405 4293511033 4293577033 4294105718 4294171257 4294038641 4294170495 4294103156 4293970801 4293971324 4293640551 4292915263 4293709969 4294371787 4294239138 4294107034 4294040985 4293842310 4293510493 4294036070 4293969512 4293310802 4293378927 4294437840 0 0 0 0 0 4294635995 4293509979 4293773681 4293113677 4293974434 4294967037 0 0 0 0 0 0 4293180237 4293245257 4293312869 4294702567 0 0 0 0 0 0 0 4294106534 4292849719 4294040744 0 0 0 0 0 0 0 0 0 4294239161 4294570202 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>flag (in category 'private') ----- - flag - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288859642 4288400378 4287284473 4286102264 4284132854 4283673334 4283016693 4284036633 4284036633 4284036633 4294967295 4294967295 4288400378 4293259774 4293259774 4293259774 4289188346 4288859642 4288859642 4282294213 4289820229 4284036633 4294967295 4294967295 4287284473 4293259774 4284132854 4283673334 4283016693 4282688501 4282425845 4282023874 4289820229 4284627477 4294967295 4294967295 4284132854 4289188346 4283279606 4283016693 4282425845 4282425845 4282425845 4281886101 4289820229 4284036633 4294967295 4294967295 4283673334 4288400378 4283016693 4282819829 4282425845 4282425845 4282425845 4281886101 4289820229 4283708184 4294967295 4294967295 4283016693 4287284473 4285250295 4285250295 4284856054 4284856054 4284856054 4284627477 4289820229 4283708184 4294967295 4294967295 4282232813 4282232813 4282167001 4282167001 42 82034889 4282294213 4281965995 4284036633 4289820229 4283708184 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4284036633 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4284036633 4284036633 4294967295) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>font (in category 'private') ----- - font - - | icon f1 f2 | - icon := Form extent: 16 at 16 depth: 32. - f1 := StrikeFont familyName: 'Bitmap DejaVu Sans' pointSize: 7.5. - f2 := StrikeFont familyName: 'Bitmap DejaVu Sans' pointSize: 10.5. - icon getCanvas - drawString: 'A' at: 0@ (15 - f1 height) font: f1 color: Color black; - drawString: 'A' at: (f1 widthOf: $A) @ (15 - f2 height) font: f2 color: Color black. - ^ icon! Item was removed: - ----- Method: ToolIcons class>>iconForClass: (in category 'support') ----- - iconForClass: aClassNameSymbol - - self environment - at: aClassNameSymbol - ifPresent: [:global | - (global respondsTo: #toolIcon) ifTrue: [ - ^ global toolIcon]] - ifAbsent: [^ #blank]. - ^ #blank! Item was removed: - ----- Method: ToolIcons class>>iconForClass:selector: (in category 'support') ----- - iconForClass: aBehavior selector: aSelector - "Answer an icon to be shown for the selector aSymbol in aBehavior." - (aBehavior respondsTo: #toolIconSelector:) ifTrue: [ - ^ aBehavior toolIconSelector: aSelector]. - ^ #blank - ! Item was removed: - ----- Method: ToolIcons class>>iconNamed: (in category 'accessing') ----- - iconNamed: aSymbol - - ^self icons at: aSymbol ifAbsentPut: [self perform: aSymbol]! Item was removed: - ----- Method: ToolIcons class>>icons (in category 'accessing') ----- - icons - - ^ Icons ifNil: [Icons := Dictionary new]! Item was removed: - ----- Method: ToolIcons class>>keyboardButtonLabeled: (in category 'buttons') ----- - keyboardButtonLabeled: stringOrForm - - ^ self keyboardButtonLabeled: stringOrForm dyed: Color black! Item was removed: - ----- Method: ToolIcons class>>keyboardButtonLabeled:dyed: (in category 'buttons') ----- - keyboardButtonLabeled: anObject dyed: aColor - - | id form c width height elevation thickness font margins color label | - thickness := RealEstateAgent scaleFactor rounded. - - anObject isForm - ifTrue: [label := anObject] - ifFalse: [ - label := anObject asString. - id := (#button, label, thickness) asSymbol. - self icons at: id ifPresent: [:icon | - ^ aColor ~= Color black - ifTrue: [icon dyed: aColor] - ifFalse: [icon]]]. - - elevation := (thickness * 2.5) rounded. - font := Preferences standardButtonFont. - color := Color black. - - margins := (font widthOf: $x) @ (font height // 2). - width := label isForm ifTrue: [label width] ifFalse: [font widthOfString: label]. - height := label isForm ifTrue: [label height] ifFalse: [font height]. - - form := Form - extent: (width + (2* margins x)) @ (height + (2* margins y) + elevation) - depth: 32. - - c := form getCanvas. - c - frameRoundRect: (0 at 0 extent: form extent - (0 at elevation)) - radius: thickness * 5 - width: thickness - color: Color black. - - elevation > 0 ifTrue: [ - c - clipBy: (0@ (form height // 2) corner: form width @ form height) - during: [:c2 | - c2 - frameRoundRect: (0@ elevation extent: form extent - (0 at elevation)) - radius: thickness * 5 - width: thickness - color: Color black]]. - - label isForm - ifTrue: [ c paintImage: label at: margins x @ (margins y)] - ifFalse: [ - c - drawString: label - at: margins x @ (margins y) - font: font - color: color]. - - id ifNotNil: [self icons at: id put: form]. - - ^ aColor ~= Color black - ifTrue: [form dyed: aColor] - ifFalse: [form]! Item was removed: - ----- Method: ToolIcons class>>magnitude (in category 'private') ----- - magnitude - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 4292861919 4286677377 4286479998 4287993237 4288059030 4287598479 4285756275 4285164138 4287072135 0 0 0 0 4288059030 4290690750 4287730065 4289901234 4289703855 4289243304 4289309097 4288322202 0 0 0 0 4293322470 4287335307 4287664272 4292532954 0 0 0 4286611584 0 0 0 0 0 4290295992 4288651167 4286151033 4294309365 0 0 0 0 0 0 0 0 0 4286677377 4288387995 4290164406 0 0 0 0 0 0 0 0 0 4290953922 4284637794 4288124823 0 0 0 0 0 0 0 0 4294309365 4285229931 4285164138 0 0 0 0 0 0 0 0 0 4287269514 4285690482 4288387995 0 0 0 4281611316 0 0 0 0 4290690750 4285493103 4285361517 0 0 4294177779 0 4282137660 0 0 0 4292796126 4283914071 4283782485 4288716960 4288585374 4287598479 4283190348 4281216558 4284440415 0 0 0 4290493371 4285822068 4285558896 4285229931 4285032552 4284835173 4284637794 4284440415 4286940549 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>morph (in category 'private') ----- - morph - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 4289839580 4288331238 4287542498 4287607777 4287475934 4287344604 4287278554 4287146969 4286949590 4287278037 4288525266 4290234076 4287934423 4287543013 4287016930 4287016930 4286950879 4286885086 4286819293 4286753500 4286621914 4286884827 4286751180 4288196048 4286754273 4287214049 4287608033 4287410913 4287345381 4287673834 4287476968 4287279842 4287542498 4287543013 4286161107 4286291404 4288593123 4293719549 4292209405 4293259773 4293587947 4291880146 4292931041 4293916413 4292668925 4293522685 4289708509 4287144908 4289249763 4291159551 4285840895 4289189887 4290435500 4284722775 4288005764 4291947263 4287417087 4290503935 4290234076 4287341514 4288986848 4291684863 4286957055 4290043135 4290830265 4285314924 4288597652 4292209919 4288008191 4290897919 4290036186 4287209670 4288461538 4293850862 4291814867 4293063142 4294767338 4294434247 4294568413 4294638062 4294176722 4294769125 4289576667 4286684358 4288920552 4290436015 4284919642 4287416979 4294953900 42 94936894 4294946435 4294307254 4294235741 4294961804 4289445600 4286487243 4288788710 4291421627 4285904999 4288533664 4294956727 4294941008 4294950033 4294899137 4294696554 4294963868 4289642464 4286355142 4287079630 4292469742 4292075239 4292206827 4292468971 4292467684 4292468200 4292337385 4292271331 4292271590 4287932618 4286157760 4287933133 4287671254 4287867353 4287473106 4286882253 4286685904 4286554058 4286552260 4286486986 4286355142 4286617792 4288458446 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>no (in category 'private') ----- - no - - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1357600601 2162906969 2162906969 820729689 0 0 0 0 0 0 283858777 3488307033 4293613401 4293613401 4293613401 4293613401 3219871577 283858777 0 0 0 0 3488307033 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 3219871577 0 0 0 1357600601 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 820729689 0 0 2162906969 4293613401 4294628822 4294628822 4294628822 4294628822 4294628822 4294628822 4293613401 1894471513 0 0 2162906969 4293613401 4294628822 4294628822 4294628822 4294628822 4294628822 4294628822 4293613401 1894471513 0 0 820729689 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 820729689 0 0 0 3219871577 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 2951436121 0 0 0 0 283858777 3219871577 4293613401 4293613401 4293613401 4293613401 2951436121 283858777 0 0 0 0 0 0 820729689 1894471513 1894471513 820729689 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>notOverridden (in category 'private') ----- - notOverridden - - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4292955472 4292955472 4292955472 4292955472 4292955472 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294940569 4294940569 4294936200 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294937229 4294937999 4294936200 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294937229 4294937999 4294535787 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294936458 4294535787 4294535787 4292889936 0 0 0 0 0 0 4292955472 4292955472 4292955472 4292955472 4292759120 4292236111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>primitive (in category 'private') ----- - primitive - - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4288124823 4288124823 9934743 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4288124823 4288782753 4288782753 4288124823 9934743 16777215 16777215 16777215 16777215 16777215 16777215 4288124823 4288782753 4288782753 4289045925 4289440683 4288124823 9934743 16777215 16777215 16777215 16777215 4288124823 4288782753 4288782753 4289045925 4289045925 4289440683 4288848546 4288124823 16777215 16777215 16777215 16777215 4288124823 4288782753 4289045925 4289045925 4289045925 4288848546 4288848546 4288124823 16777215 16777215 16777215 16777215 9934743 4288124823 4289440683 4289440683 4288848546 4288848546 4288124823 10658466 16777215 16777215 16777215 16777215 9934743 10592673 4288124823 4288848 546 4288848546 4288124823 10658466 10658466 16777215 16777215 16777215 16777215 16777215 9934743 11250603 4288124823 4288124823 10658466 10658466 9934743 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>stream (in category 'private') ----- - stream - - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294967295 4294967295 0 0 4294967295 4294967295 0 0 0 0 0 4294967295 4290038244 4292075503 4294967295 4294967295 4290038244 4292075503 4294967295 0 0 0 0 4294967295 4288921054 4284189380 4292535794 4294967295 4288921054 4284189380 4292535794 4294967295 0 0 0 4294967295 4288921054 4283597761 4284386245 4293850105 4289183968 4283597761 4284386245 4292995828 4294967295 0 0 4294967295 4288921054 4283597761 4283597761 4288461275 4289381089 4283597761 4283597761 4284583622 4293784313 4294967295 0 4294967295 4288921054 4283597761 4283597761 4288198106 4289381088 4283597761 4283597761 4284123588 4293192949 4294967295 0 4294967295 4288921054 4283597761 4283926211 4293127157 4289183968 4283597761 4283926211 4291812590 4294967295 0 0 4294967295 4288921054 4283794882 4291155690 4294967295 4288921054 4283794882 4291155690 4294967295 0 0 0 4294967295 4289381088 4290629607 4294967295 4294967295 4289381088 4290629607 4294967295 0 0 0 0 4294967295 42949672 95 4294967295 0 4294967295 4294967295 4294967295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - offset: 0 at 0! Item was removed: - ----- Method: ToolIcons class>>string (in category 'private') ----- - string - - ^ Form - extent: 12 at 12 - depth: 32 - fromArray: #( 0 0 4292077049 4285510895 4285577969 4285577455 4285577199 4285577199 4285577199 4285771759 0 0 0 0 4285249007 4286956786 4287810035 4287218674 4285837807 0 4285771759 4285771503 0 0 0 0 4285577455 4287809779 4287809779 4287152882 4285771759 0 4285705967 4285705965 0 0 0 0 4285838063 4286562033 4287743987 4287152882 4285771503 0 4285705453 4285639661 0 0 0 0 4293981949 4286231022 4285642223 4286495729 4285705453 0 4285639661 4285639149 0 0 0 0 0 0 4293981693 4285377517 4285639661 0 4285638893 4285638892 0 0 0 0 0 0 0 4285639661 4285638893 0 4285638892 4285572844 0 0 0 0 0 0 0 4285638893 4285638892 0 4285572844 4285507052 0 0 0 0 0 0 0 4285638380 4285572844 0 4285507052 4285506540 0 0 0 0 0 0 0 4285507052 4285507052 0 4285506540 4285506284 0 0 0 0 0 0 0 4285506796 4285506540 0 4285506028 4285440492 0 0 0 0 0 0 0 4285506284 4285506284 0 4285440236 4285440234 0 0) - offset: 0 at 0! Item was removed: - ----- Method: TranscriptStream class>>buildWith: (in category '*Tools') ----- - buildWith: aBuilder - ^(Smalltalk at: #Transcript) buildWith: aBuilder! Item was removed: - ----- Method: TranscriptStream class>>openMorphicTranscript (in category '*Tools') ----- - openMorphicTranscript - "Have the current project's transcript open up as a morph" - - ^ToolBuilder open: self! Item was removed: - ----- Method: TranscriptStream>>buildWith: (in category '*Tools') ----- - buildWith: builder - | windowSpec textSpec | - windowSpec := builder pluggableWindowSpec new. - windowSpec model: self. - windowSpec label: 'Transcript'. - windowSpec children: OrderedCollection new. - - textSpec := builder pluggableTextSpec new. - textSpec - model: self; - menu: #codePaneMenu:shifted:; - frame: (0 at 0corner: 1 at 1). - windowSpec children add: textSpec. - - ^builder build: windowSpec! Item was removed: - ----- Method: TranscriptStream>>codePaneMenu:shifted: (in category '*Tools') ----- - codePaneMenu: aMenu shifted: shifted - "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items" - ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted - ! Item was removed: - ----- Method: TranscriptStream>>open (in category '*Tools') ----- - open - | openCount | - openCount := self countOpenTranscripts. - openCount = 0 - ifTrue: [self openLabel: 'Transcript'] - ifFalse: [self openLabel: 'Transcript #' , (openCount+1) printString]! Item was removed: - ----- Method: TranscriptStream>>openIfNone (in category '*Tools') ----- - openIfNone - "Open a transcript window if there are no open windows." - - self countOpenTranscripts = 0 ifTrue: [self open]! Item was removed: - ----- Method: TranscriptStream>>openLabel: (in category '*Tools') ----- - openLabel: aString - "Open a window on this transcriptStream" - ^ToolBuilder open: self label: aString! Item was removed: - ----- Method: TranscriptStream>>postAcceptBrowseFor: (in category '*Tools') ----- - postAcceptBrowseFor: aModel - "Nothing to do."! Item was removed: - ----- Method: TranscriptStream>>representsSameBrowseeAs: (in category '*Tools') ----- - representsSameBrowseeAs: anotherModel - ^ true! Item was removed: - ----- Method: TranscriptStream>>saveContents:accessMode: (in category '*Tools-file out') ----- - saveContents: stringContents accessMode: accessMode - "Interactive callback from TextEditor. See commentary in Model class." - - ^ (Project uiManager - saveFilenameRequest: 'Save text contents in file...' - initialAnswer: 'Transcript.text') - ifNil: [false] ifNotNil: [:answer | answer ifEmpty: [false] - ifNotEmpty: [:fileName | - Model new - saveContents: stringContents - onFileNamed: fileName - accessMode: accessMode]].! Item was removed: - ----- Method: Unicode class>>browseClassCommentsWithLeadingCharEncoding (in category '*Tools-Browsing') ----- - browseClassCommentsWithLeadingCharEncoding - "See commentary in browseMethodsWithLeadingCharEncoding." - - ^ self systemNavigation - browseMessageList: (Array streamContents: [:s | - self systemNavigation - allClassesDo: [:cls | - (cls comment asString anySatisfy: [:each | each codePoint > 255]) - ifTrue: [s nextPut: (MethodReference class: cls selector: #Comment)] ]]) - name: 'Class comments affected by #leadingChar'! Item was removed: - ----- Method: Unicode class>>browseClassCommentsWithNonAsciiEncoding (in category '*Tools-Browsing') ----- - browseClassCommentsWithNonAsciiEncoding - "See commentary in browseMethodsWithNonAsciiEncoding." - - ^ self systemNavigation - browseMessageList: (Array streamContents: [:s | - self systemNavigation - allClassesDo: [:cls | cls comment asString isAsciiString - ifFalse: [s nextPut: (MethodReference class: cls selector: #Comment)] ]]) - name: 'Class comments with non-ASCII contents'! Item was removed: - ----- Method: Unicode class>>browseMethodsWithLeadingCharEncoding (in category '*Tools-Browsing') ----- - browseMethodsWithLeadingCharEncoding - "Browse a list of methods whose sources are affected by Squeak's #leadingChar magic, which can confuse tools such as TextDiff depending on your current encoding (i.e., EncodedCharSet or LanguageEnvironment). NOTE THAT if you want to change those methods, ensure that your current encoding uses a leadingChar of 0, e.g., locale en-US and Latin1Environment. See UTF8TextConverter class >> #decodeByteString: and Unicode class >> #value:." - - ^ self systemNavigation - browseMessageList: (self systemNavigation - allMethodsSelect: [:method | method getSource asString - anySatisfy: [:each | each codePoint > 255]]) - name: 'Methods sources affected by #leadingChar'! Item was removed: - ----- Method: Unicode class>>browseMethodsWithNonAsciiEncoding (in category '*Tools-Browsing') ----- - browseMethodsWithNonAsciiEncoding - "Browse a list of methods whose sources benefit from UTF8 encoding." - - ^ self systemNavigation - browseMessageList: (self systemNavigation - allMethodsSelect: [:method | method getSource asString isAsciiString not]) - name: 'Methods with non-ASCII sources'! Item was removed: - ----- Method: Utilities class>>browseRecentSubmissions (in category '*Tools') ----- - browseRecentSubmissions - "Open up a browser on the most recent methods submitted in the image." - ^ RecentMessageSet - openMessageList: RecentMessages default methodReferences - name: 'Recent Submissions' - autoSelect: nil! Item was removed: - ----- Method: Utilities class>>closeAllDebuggers (in category '*Tools') ----- - closeAllDebuggers - "Utilities closeAllDebuggers" - Smalltalk isMorphic - ifTrue: - [((Smalltalk at: #SystemWindow) allSubInstances select: [:w | w model isKindOf: Debugger]) - do: [:w | w delete]] - ifFalse: - [((Smalltalk at: #StandardSystemController) allInstances select: [:w | w model isKindOf: Debugger]) - do: [:w | w closeAndUnscheduleNoTerminate]]! Item was removed: - ----- Method: Utilities class>>openRecentSubmissionsBrowser (in category '*Tools') ----- - openRecentSubmissionsBrowser - "Open up a browser on the most recent methods submitted in the image; reuse any existing one found in the world." - self deprecated: 'use #browseRecentSubmissions'. - self browseRecentSubmissions! Item was removed: - ----- Method: Utilities class>>recentSubmissionsWindow (in category '*Tools') ----- - recentSubmissionsWindow - "Answer a SystemWindow holding recent submissions" - | messageSet | - messageSet := RecentMessageSet messageList: RecentMessages default methodReferences. - messageSet - autoSelectString: nil; - setInitialLabel: 'Recent Submissions'. - ^ ToolBuilder build: messageSet! Item was removed: - ChangeList subclass: #VersionsBrowser - instanceVariableNames: 'classOfMethod selectorOfMethod addedChangeRecord' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - - !VersionsBrowser commentStamp: 'nk 11/25/2003 10:04' prior: 0! - VersionsBrowser shows all the versions of a particular method, and lets you compare them, revert to selected versions, and so on.! Item was removed: - ----- Method: VersionsBrowser class>>browseMethod: (in category 'instance creation') ----- - browseMethod: aCompiledMethod - - ^ (self browseVersionsOf: aCompiledMethod) - ifNotNil: [:browser | - browser selectMethod: aCompiledMethod]; - yourself! Item was removed: - ----- Method: VersionsBrowser class>>browseVersionsForClass:selector: (in category 'instance creation') ----- - browseVersionsForClass: aClass selector: aSelector - - ^ self - browseVersionsOf: (aClass compiledMethodAt: aSelector) - class: aClass - meta: aClass isMeta - category: (aClass organization categoryOfElement: aSelector) - selector: aSelector! Item was removed: - ----- Method: VersionsBrowser class>>browseVersionsOf: (in category 'instance creation') ----- - browseVersionsOf: aCompiledMethod - - | methodClass methodSelector | - methodClass := aCompiledMethod methodClass. - methodSelector := aCompiledMethod selector. - ^ self - browseVersionsOf: aCompiledMethod - class: methodClass - meta: methodClass isMeta - category: (methodClass organization categoryOfElement: methodSelector) - selector: methodSelector! Item was removed: - ----- Method: VersionsBrowser class>>browseVersionsOf:class:meta:category:selector: (in category 'instance creation') ----- - browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector - ^ self browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: nil! Item was removed: - ----- Method: VersionsBrowser class>>browseVersionsOf:class:meta:category:selector:lostMethodPointer: (in category 'instance creation') ----- - browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer - | changeList browser | - Cursor read showWhile: - [changeList := (browser := self new) - scanVersionsOf: method class: class meta: meta - category: msgCategory selector: selector]. - changeList ifNil: [ self inform: 'No versions available' translated. ^nil ]. - - sourcePointer ifNotNil: - [changeList setLostMethodPointer: sourcePointer]. - - self open: changeList name: ('Recent versions of {1}' translated format: {selector}) multiSelect: false. - - ^browser! Item was removed: - ----- Method: VersionsBrowser class>>timeStampFor:class:reverseOrdinal: (in category 'instance creation') ----- - timeStampFor: aSelector class: aClass reverseOrdinal: anInteger - "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." - - | method aChangeList | - method := aClass compiledMethodAt: aSelector ifAbsent: [^ nil]. - aChangeList := self new - scanVersionsOf: method class: aClass meta: aClass isMeta - category: nil selector: aSelector. - ^ aChangeList ifNil: [nil] ifNotNil: - [aChangeList list size >= anInteger - ifTrue: - [(aChangeList changeList at: anInteger) stamp] - ifFalse: - [nil]]! Item was removed: - ----- Method: VersionsBrowser class>>versionCountForSelector:class: (in category 'instance creation') ----- - versionCountForSelector: aSelector class: aClass - "Answer the number of versions known to the system for the given class and method, including the current version. A result of greater than one means that there is at least one superseded version. Answer zero if no logged version can be obtained." - - | method aChangeList | - method := aClass compiledMethodAt: aSelector ifAbsent: [^ 0]. - aChangeList := self new - scanVersionsOf: method class: aClass meta: aClass isMeta - category: nil selector: aSelector. - ^ aChangeList ifNil: [0] ifNotNil: [aChangeList list size]! Item was removed: - ----- Method: VersionsBrowser>>aboutToStyle: (in category 'contents') ----- - aboutToStyle: aStyler - - "Style in source view, or when there's nothing to diff with." - (self isModeStyleable or: [ listIndex = list size ]) ifFalse: [ ^false ]. - aStyler - classOrMetaClass: classOfMethod; - parseAMethod: true. - ^true - ! Item was removed: - ----- Method: VersionsBrowser>>addPriorVersionsCountForSelector:ofClass:to: (in category 'misc') ----- - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior versions are seen in a versions browser -- in this case, the inherited version of this method will not work." - - (aClass includesSelector: aSelector) ifTrue: - [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. - - aStream nextPutAll: - ((changeList size > 0 - ifTrue: - [changeList size = 1 - ifTrue: - ['Deleted - one prior version' translated] - ifFalse: - ['Deleted - ', changeList size printString, ' prior versions']] - ifFalse: - ['surprisingly, no prior versions' translated]), self annotationSeparator)! Item was removed: - ----- Method: VersionsBrowser>>addedChangeRecord (in category 'init & update') ----- - addedChangeRecord - ^addedChangeRecord! Item was removed: - ----- Method: VersionsBrowser>>addedChangeRecord: (in category 'init & update') ----- - addedChangeRecord: aChangeRecord - addedChangeRecord := aChangeRecord. - self reformulateList.! Item was removed: - ----- Method: VersionsBrowser>>changeListButtonSpecs (in category 'init & update') ----- - changeListButtonSpecs - - ^#( - ('compare to current' - compareToCurrentVersion - 'opens a separate window which shows the text differences between the selected version and the current version') - - ('revert' - fileInSelections - 'reverts the method to the version selected') - - ('remove from changes' - removeMethodFromChanges - 'remove this method from the current change set') - - ('help' - offerVersionsHelp - 'further explanation about use of Versions browsers') - )! Item was removed: - ----- Method: VersionsBrowser>>changeListKey:from: (in category 'menu') ----- - changeListKey: aChar from: view - "Respond to a Command key in the list pane. of the versions browser" - - ^ self messageListKey: aChar from: view! Item was removed: - ----- Method: VersionsBrowser>>classCommentIndicated (in category 'misc') ----- - classCommentIndicated - "Answer whether the receiver is pointed at a class comment" - - ^ false! Item was removed: - ----- Method: VersionsBrowser>>compareToOtherVersion (in category 'menu') ----- - compareToOtherVersion - "Prompt the user for a reference version, then spawn a window - showing the diffs between the older and the newer of the current - version and the reference version as text." - - | change1 change2 s1 s2 | - change1 := changeList at: listIndex ifAbsent: [ ^self ]. - - change2 := ((UIManager default - chooseFrom: (list copyWithoutIndex: listIndex) - values: (changeList copyWithoutIndex: listIndex))) ifNil: [ ^self ]. - - "compare earlier -> later" - "change1 timeStamp < change2 timeStamp - ifFalse: [ | temp | temp := change1. change1 := change2. change2 := temp ]." - - s1 := change1 string. - s2 := change2 string. - s1 = s2 - ifTrue: [^ self inform: 'Exact Match' translated]. - - (StringHolder new - textContents: (TextDiffBuilder - buildDisplayPatchFrom: s1 - to: s2 - inClass: classOfMethod - prettyDiffs: self showingPrettyDiffs)) - openLabel: (('Comparison from {1} to {2}' translated) format: { change1 stamp. change2 stamp })! Item was removed: - ----- Method: VersionsBrowser>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.782 g: 0.677 b: 0.9)! Item was removed: - ----- Method: VersionsBrowser>>fileInSelections (in category 'menu') ----- - fileInSelections - super fileInSelections. - self reformulateList! Item was removed: - ----- Method: VersionsBrowser>>fileOutSelection (in category 'menu') ----- - fileOutSelection - | them it file | - them := OrderedCollection new. - listSelections with: changeList do: - [:selected :item | selected ifTrue: [them add: item]]. - them size ~= 1 - ifTrue: [self inform: 'single version not selected, so nothing done' translated] - ifFalse: - [it := them first. - file := FileStream newFileNamed: it methodClassName, (it isMetaClassChange ifTrue: [' class'] ifFalse: ['']), '-' , (it methodSelector copyReplaceAll: ':' with: ''). - [file header; timeStamp. - it fileOutOn: file] ensure: [file close]]! Item was removed: - ----- Method: VersionsBrowser>>findOriginalChangeSet (in category 'menu') ----- - findOriginalChangeSet - | changeSet | - self currentChange ifNil: [^ self]. - changeSet := self currentChange originalChangeSetForSelector: self selectedMessageName. - changeSet = #sources ifTrue: - [^ self inform: 'This version is in the .sources file.' translated]. - changeSet ifNil: - [^ self inform: 'This version was not found in any changeset nor in the .sources file.' translated]. - (ChangeSorter new myChangeSet: changeSet) open! Item was removed: - ----- Method: VersionsBrowser>>initialExtent (in category 'user interface') ----- - initialExtent - - "adopt the extent so that the revert button fits in" - ^650 at 400! Item was removed: - ----- Method: VersionsBrowser>>listSelectionVersionsMenu: (in category 'menu') ----- - listSelectionVersionsMenu: aMenu - "Fill aMenu with menu items appropriate to the receiver" - <versionsMenu> - - listIndex > 0 ifTrue:[ - (list size > 1 ) ifTrue: [ aMenu addTranslatedList: #( - ('compare to current' compareToCurrentVersion 'compare selected version to the current version') - ('compare to version...' compareToOtherVersion 'compare selected version to another selected version'))]. - "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" - aMenu addTranslatedList: #( - ('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version') - ('fileOut selected version' fileOutSelection 'file out the selected version') )]. - ^ aMenu! Item was removed: - ----- Method: VersionsBrowser>>mainVersionsMenu: (in category 'menu') ----- - mainVersionsMenu: aMenu - "Fill aMenu with menu items appropriate to the receiver" - <versionsMenu> - - aMenu addTranslatedList: #( - ('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present') - ('find original change set' findOriginalChangeSet 'locate the changeset which originally contained this version') - - - ('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here') - ('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality') - - - ('senders (n)' browseSenders 'browse all senders of this selector') - ('implementors (m)' browseImplementors 'browse all implementors of this selector') - ('inheritance (i)' methodHierarchy 'browse method inheritance') - - - ('help...' offerVersionsHelp 'provide an explanation of the use of this tool')). - - ^aMenu! Item was removed: - ----- Method: VersionsBrowser>>optionalButtonPairs (in category 'toolbuilder') ----- - optionalButtonPairs - - ^ #(('revert' fileInSelections 'resubmit the selected version, so that it becomes the current version')) , super optionalButtonPairs! Item was removed: - ----- Method: VersionsBrowser>>reformulateList (in category 'init & update') ----- - reformulateList - | aMethod | - "Some uncertainty about how to deal with lost methods here" - aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ self]. - - self scanVersionsOf: aMethod class: classOfMethod theNonMetaClass meta: classOfMethod isMeta category: (classOfMethod whichCategoryIncludesSelector: selectorOfMethod) selector: selectorOfMethod. - self changed: #list. "for benefit of mvc" - listIndex := 1. - self changed: #listIndex. - self contentsChanged - ! Item was removed: - ----- Method: VersionsBrowser>>removeMethodFromChanges (in category 'menu') ----- - removeMethodFromChanges - "Remove my method from the current change set" - - ChangeSet current removeSelectorChanges: selectorOfMethod class: classOfMethod. - self changed: #annotation - ! Item was removed: - ----- Method: VersionsBrowser>>scanVersionsOf:class:meta:category:selector: (in category 'init & update') ----- - scanVersionsOf: method class: class meta: meta category: category selector: selector - - selectorOfMethod := selector. - currentCompiledMethod := method. - classOfMethod := meta ifTrue: [class class] ifFalse: [class]. - changeList := OrderedCollection new. - list := OrderedCollection new. - self addedChangeRecord ifNotNil: [ :change | - self - addItem: change - text: ('{1} (in {2})' translated - format: { change stamp. change fileName }) ]. - listIndex := 0. - (ChangeSet scanVersionsOf: method class: class meta: meta category: category selector: selector) - ifNil: [^ nil]; - do: [ :change | - self - addItem: change - text: ('{1} {2} {3} \{{4}\}' translated format: { - change stamp. classOfMethod name. selector. change category })]. - listSelections := Array new: list size withAll: false.! Item was removed: - ----- Method: VersionsBrowser>>selectMethod: (in category 'menu') ----- - selectMethod: aCompiledMethod - - self toggleListIndex: (self changeList indexOf: ( - self changeList detect: [:change | - change stamp = aCompiledMethod timeStamp and: [ - change string = aCompiledMethod getSource asString]]))! Item was removed: - ----- Method: VersionsBrowser>>selectedClass (in category 'misc') ----- - selectedClass - "Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" - - ^ classOfMethod theNonMetaClass! Item was removed: - ----- Method: VersionsBrowser>>selectedClassOrMetaClass (in category 'misc') ----- - selectedClassOrMetaClass - "Answer the class or metaclass currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" - - ^ classOfMethod! Item was removed: - ----- Method: VersionsBrowser>>selectedMessageName (in category 'misc') ----- - selectedMessageName - "Answer the message name currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" - - ^ selectorOfMethod! Item was removed: - ----- Method: VersionsBrowser>>showsVersions (in category 'misc') ----- - showsVersions - ^ true! Item was removed: - ----- Method: VersionsBrowser>>titleVersionsMenu: (in category 'menu') ----- - titleVersionsMenu: aMenu - "Add a menu title atop aMenu" - <versionsMenu> - <menuPriority: 100> - aMenu title: 'Versions' translated. - aMenu addStayUpItemSpecial. - ^ aMenu! Item was removed: - ----- Method: VersionsBrowser>>toggleListIndex: (in category 'viewing access') ----- - toggleListIndex: newListIndex - - listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false]. - newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true]. - - super toggleListIndex: newListIndex.! Item was removed: - ----- Method: VersionsBrowser>>updateListsAndCodeIn: (in category 'init & update') ----- - updateListsAndCodeIn: aWindow - | aMethod | - aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false]. - aMethod == currentCompiledMethod - ifFalse: - ["Do not attempt to formulate if there is no source pointer. - It probably means it has been recompiled, but the source hasn't been written - (as during a display of the 'save text simply?' confirmation)." - aMethod last ~= 0 ifTrue: [self reformulateList]]. - ^ true - ! Item was removed: - ----- Method: VersionsBrowser>>versionFrom: (in category 'menu') ----- - versionFrom: secsSince1901 - - "Return changeRecord of the version in effect at that time. Accept in the VersionsBrowser does not use this code." - - changeList do: [:cngRec | | vTime strings | - (strings := cngRec stamp findTokens: ' ') size > 2 ifTrue: [ - vTime := strings second asDate asSeconds + - strings third asTime asSeconds. - vTime <= secsSince1901 ifTrue: ["this one" - ^ cngRec == changeList first ifTrue: [nil] ifFalse: [cngRec]]]]. - "was not defined that early. Don't delete the method." - ^ changeList last "earliest one may be OK" ! Item was removed: - ----- Method: VersionsBrowser>>versionsHelpString (in category 'menu') ----- - versionsHelpString - ^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc. - - To revert to an earlier version, select it (in the list pane) and then do any of the following: - * Choose "revert to this version" from the list pane menu. - * Hit the "revert" button, - * Type ENTER in the code pane - * Type cmd-s (alt-s) in the code pane. - - The code pane shows the source for the selected version. If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane. Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button, or hitting cmd-D when the cursor is over the list pane. - - To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button. (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.) - - You can also compare the selected version with any other version using the "compare to version..." menu choice. - - If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that smart updating be maintained; if you''re in mvc or in morphic but with smart-updating turned off, a versions browser is only brought up to date when you activate its window (and when you issue "revert" from within it, of course,) and you can also use the "update list" command to make certain the versions list is up to date. - - Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set. This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion. - - Note: the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.' translated! Item was removed: - ----- Method: VersionsBrowser>>versionsMenu: (in category 'menu') ----- - versionsMenu: aMenu - - ^ self menu: aMenu for: #(versionsMenu versionsMenuShifted:) - ! Item was removed: - ----- Method: WeakSet>>inspectorClass (in category '*Tools-Inspector') ----- - inspectorClass - ^ WeakSetInspector! Item was removed: - SetInspector subclass: #WeakSetInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - - !WeakSetInspector commentStamp: '<historical>' prior: 0! - A verison of the SetInspector specialized for inspecting WeakSets. It knows about the flag object used to indicate empty locations in the hash table.! Item was removed: - ----- Method: WeakSetInspector>>isElementValid: (in category 'private') ----- - isElementValid: anElement - "Consider the #flag object, which is used to mark GC'ed elements in the WeakSet." - - ^ anElement notNil and: [anElement ~~ (self object instVarNamed: #flag)]! Item was removed: - StringHolder subclass: #Workspace - instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables shouldStyle environment windowTitle fileDirectory fileLineEndConvention' - classVariableNames: 'DeclareVariablesAutomatically EmbedTranscript FileOutFilePath FileOutOnAccept LookupPools ShouldStyle' - poolDictionaries: '' - category: 'Tools-Base'! - - !Workspace commentStamp: 'fbs 6/2/2012 20:46' prior: 0! - A Workspace is a text area plus a lot of support for executable code. It is a great place to execute top-level commands to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods. - - To open a new workspace, execute: - - Workspace open - - - A workspace can have its own variables, called "workspace variables", to hold intermediate results. For example, if you type into a workspace "x := 5" and do-it, then later you could type in "y := x * 2" and y would become 10. - - Additionally, in Morphic, a workspace can gain access to morphs that are on the screen. If acceptDroppedMorphs is turned on, then whenever a morph is dropped on the workspace, a variable will be created which references that morph. This functionality is toggled with the window-wide menu of a workspace. - - - The instance variables of this class are: - - bindings - holds the workspace variables for this workspace - - acceptDroppedMorphs - whether dropped morphs should create new variables! Item was removed: - ----- Method: Workspace class>>addLookupPool: (in category 'lookup pools') ----- - addLookupPool: sharedPool - "Add a SharedPool that bindings should be looked up in." - LookupPools ifNil: [LookupPools := IdentitySet new]. - LookupPools add: sharedPool! Item was removed: - ----- Method: Workspace class>>clearLookupPools (in category 'lookup pools') ----- - clearLookupPools - LookupPools := nil. - ! Item was removed: - ----- Method: Workspace class>>declareVariablesAutomatically (in category 'preferences') ----- - declareVariablesAutomatically - <preference: 'Automatically declare variables in Workspaces' - category: 'browsing' - description: 'If true, workspaces automatically create variables.' - type: #Boolean> - ^DeclareVariablesAutomatically ifNil: [true]! Item was removed: - ----- Method: Workspace class>>declareVariablesAutomatically: (in category 'preferences') ----- - declareVariablesAutomatically: aBoolean - DeclareVariablesAutomatically := aBoolean! Item was removed: - ----- Method: Workspace class>>embedTranscript (in category 'preferences') ----- - embedTranscript - <preference: 'Embed a Transcript in Workspace' - categoryList: #('browsing' 'tools') - description: 'If true, new workspaces will open with an embedded Transcript.' - type: #Boolean> - ^ EmbedTranscript ifNil: [ false ]! Item was removed: - ----- Method: Workspace class>>embedTranscript: (in category 'preferences') ----- - embedTranscript: aBoolean - - EmbedTranscript := aBoolean.! Item was removed: - ----- Method: Workspace class>>fileOutOnAccept (in category 'preferences') ----- - fileOutOnAccept - <preference: 'File-out workspace contents on accept' - categoryList: #('browsing' 'tools') - description: 'If true, accepting contents in a workspace will append them to a file on disk. The file name is derived from the workspace''s current window title and can thus be changed. The default name is thus ''Workspace.text''.' - type: #Boolean> - ^ FileOutOnAccept ifNil: [ true ]! Item was removed: - ----- Method: Workspace class>>fileOutOnAccept: (in category 'preferences') ----- - fileOutOnAccept: aBoolean - - FileOutOnAccept := aBoolean.! Item was removed: - ----- Method: Workspace class>>open (in category 'instance creation') ----- - open - - | workspace | - workspace := self new. - ^ self embedTranscript - ifTrue: [workspace buildAndOpenWorkspaceTranscript] - ifFalse: [workspace buildAndOpen]! Item was removed: - ----- Method: Workspace class>>prototypicalToolWindow (in category 'instance creation') ----- - prototypicalToolWindow - "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" - - | aWorkspace | - aWorkspace := ToolBuilder build: self new. - ^ aWorkspace! Item was removed: - ----- Method: Workspace class>>removeLookupPool: (in category 'lookup pools') ----- - removeLookupPool: sharedPool - "Workspaces should no longer look up bindings in the specified SharedPool." - LookupPools ifNil: [^self]. - LookupPools remove: sharedPool ifAbsent: [].! Item was removed: - ----- Method: Workspace class>>shouldStyle (in category 'preferences') ----- - shouldStyle - <preference: 'Shout styling in Workspace' - category: 'browsing' - description: 'If true, new workspaces use Shout to style their contents.' - type: #Boolean> - ^ ShouldStyle ifNil: [ false ]! Item was removed: - ----- Method: Workspace class>>shouldStyle: (in category 'preferences') ----- - shouldStyle: aBoolean - - ShouldStyle := aBoolean. - - self allSubInstancesDo: [:workspace | workspace changed: #style].! Item was removed: - ----- Method: Workspace>>aboutToStyle: (in category 'code pane') ----- - aboutToStyle: aStyler - - self shouldStyle ifFalse: [ ^false ]. - aStyler - classOrMetaClass: nil; - workspace: self. - ^true! Item was removed: - ----- Method: Workspace>>acceptAction (in category 'accessing') ----- - acceptAction - ^acceptAction! Item was removed: - ----- Method: Workspace>>acceptAction: (in category 'accessing') ----- - acceptAction: anAction - acceptAction := anAction.! Item was removed: - ----- Method: Workspace>>acceptContents: (in category 'accessing') ----- - acceptContents: aString - - (self class fileOutOnAccept and: [acceptAction isNil]) ifTrue: [ - (Project uiManager - confirm: ('Do you want to append the contents to\\ {1}\\on accept so that you can safely close this window?\\{2}' translated withCRs asText format: { - self suggestedFileNameForSave asText allBold. - '(You will not be asked again for this window. Use the window menu to revise your decision later. Disable this prompt via the system-wide #fileOutOnAccept preference.)' translated withCRs asText - addAttribute: (TextFontReference toFont: Preferences standardButtonFont)}) - title: 'Accept Changes') - ifTrue: [self appendContentsToFileOnAccept] - ifFalse: [acceptAction := [:edits | true ]]]. - - ^ (acceptAction ifNotNil: [acceptAction value: aString]) ~~ false - and: [super acceptContents: aString]! Item was removed: - ----- Method: Workspace>>acceptDroppedMorphsWording (in category 'drag and drop') ----- - acceptDroppedMorphsWording - - ^ self acceptsDroppingMorphForReference - ifTrue: ['<yes> create textual references to dropped morphs' translated] - ifFalse: ['<no> create textual references to dropped morphs' translated] - ! Item was removed: - ----- Method: Workspace>>acceptDroppingMorph:event:inMorph: (in category 'drag and drop') ----- - acceptDroppingMorph: dropee event: evt inMorph: targetMorph - "Return the dropee to its old position, and add a reference to it at the - cursor point." - | bindingName externalName reference | - (dropee isKindOf: TransferMorph) - ifTrue: [reference := dropee passenger. - externalName := dropee passenger className] - ifFalse: [reference := dropee. - externalName := dropee externalName]. - externalName := externalName isOctetString - ifTrue: [externalName] - ifFalse: ['a' , externalName]. - bindingName := externalName withFirstCharacterDownshifted , reference identityHash printString. - targetMorph correctSelectionWithString: bindingName , ' '. - (self bindingOf: bindingName) - value: reference. - (dropee isKindOf: TransferMorph) - ifFalse: [dropee rejectDropMorphEvent: evt]. - ^ true"success"! Item was removed: - ----- Method: Workspace>>acceptsDroppingMorphForReference (in category 'drag and drop') ----- - acceptsDroppingMorphForReference - - ^ acceptDroppedMorphs - - ! Item was removed: - ----- Method: Workspace>>acceptsDroppingMorphForReference: (in category 'drag and drop') ----- - acceptsDroppingMorphForReference: trueFalse - - acceptDroppedMorphs := trueFalse - - ! Item was removed: - ----- Method: Workspace>>addModelItemsToWindowMenu: (in category 'menu commands') ----- - addModelItemsToWindowMenu: aMenu - - aMenu addLine. - aMenu - add: 'change file name...' - target: self - action: #changeFileName. - aMenu - add: 'save contents to file...' - target: self - action: #saveContentsInFile. - aMenu - addUpdating: #saveContentsInFileOnAcceptWording - target: self - action: #saveContentsInFileOnAccept. - aMenu - addUpdating: #appendContentsToFileOnAcceptWording - target: self - action: #appendContentsToFileOnAccept. - aMenu addLine. - aMenu - add: 'inspect variables' - target: self - action: #inspectBindings. - aMenu - add: 'reset variables' - target: self - action: #resetBindings. - aMenu addLine. - aMenu - addUpdating: #mustDeclareVariableWording - target: self - action: #toggleVariableDeclarationMode. - aMenu - addUpdating: #acceptDroppedMorphsWording - target: self - action: #toggleDroppingMorphForReference. - - self addToggleStylingMenuItemTo: aMenu. - ! Item was removed: - ----- Method: Workspace>>addToggleStylingMenuItemTo: (in category 'code pane menu') ----- - addToggleStylingMenuItemTo: aMenu - - aMenu - addUpdating: #toggleStylingLabel - target: self - action: #toggleStyling! Item was removed: - ----- Method: Workspace>>appendContentsOfFile (in category 'menu commands') ----- - appendContentsOfFile - "Prompt for a file, and if one is obtained, append its contents to the contents of the receiver. Caution: as currently implemented this abandons any custom style information previously in the workspace. Someone should fix this. Also, for best results you should accept the contents of the workspace before requesting this." - - | fName | - fName := UIManager default chooseFileMatching: '*' label: 'Choose file to add to workspace'. - fName ifNil:[^self]. - - FileStream oldFileNamed: fName do:[:aFileStream| - contents := (contents ifNil: ['']) asString, aFileStream contentsOfEntireFile]. - self changed: #contents! Item was removed: - ----- Method: Workspace>>appendContentsToFileOnAccept (in category 'menu commands') ----- - appendContentsToFileOnAccept - "Arrange that the contents will be appended to a file when the user accepts." - - self saveContentsInFileOnAcceptEnabled - ifTrue: [(Project uiManager confirm: 'Do you really want to change file access mode\from #update to #append?\\You might corrupt data when accepting changes.' translated withCRs) - ifFalse: [^ self]]. - - self acceptAction: (self appendContentsToFileOnAcceptEnabled ifTrue: [ "no action" ] ifFalse: [ - [:freshContents | | fileName stringToAppend | - "Ensure to compute fileName as late as possible to consider recent changes of the #windowTitle." - fileName := self suggestedFileNameForSave. - - stringToAppend := '"----ACCEPT----{1}"\{2}\' withCRs - format: { DateAndTime now asString. freshContents }. - - ((FileDirectory forFileName: fileName) fileExists: fileName) - ifFalse: [ "If the default file name, which is derived from the current window title, does not exist, ask the user once to confirm the location." - self - saveContents: stringToAppend - accessMode: #create] - ifTrue: [ "Update/replace the contents in the existing file." - self - saveContents: stringToAppend - onFileNamed: fileName - accessMode: #append]] ]).! Item was removed: - ----- Method: Workspace>>appendContentsToFileOnAcceptEnabled (in category 'menu commands') ----- - appendContentsToFileOnAcceptEnabled - - ^ (acceptAction notNil and: [acceptAction home selector = #appendContentsToFileOnAccept])! Item was removed: - ----- Method: Workspace>>appendContentsToFileOnAcceptWording (in category 'menu commands') ----- - appendContentsToFileOnAcceptWording - - ^ (self appendContentsToFileOnAcceptEnabled - ifTrue: ['<yes> append contents to {1} on accept'] - ifFalse: ['<no> append contents to {1} on accept']) translated - format: { self suggestedFileNameForSave contractTo: 32 }! Item was removed: - ----- Method: Workspace>>bindingOf: (in category 'binding') ----- - bindingOf: aString - mustDeclareVariables ifTrue: [^ nil]. - "I want to have workspace that force the user to declare - variables. Still subclasses may want to do something else" - (bindings includesKey: aString) ifFalse: [ - (self lookupInPools: aString) - ifNotNil: [:val | - "Caveat: since we're not inserting the pool's Association into - the dictionary, assigning a new value to the variable will only - affect the one Workspace (i.e. you can't assign to a variable in a - SharedPool)." - bindings at: aString put: val] - ifNil: [aString first isUppercase - ifTrue: [^nil] - ifFalse: [bindings at: aString put: nil]] - ]. - ^ bindings associationAt: aString! Item was removed: - ----- Method: Workspace>>buildAndOpen (in category 'toolbuilder') ----- - buildAndOpen - - ToolBuilder default open: self. - ^ self! Item was removed: - ----- Method: Workspace>>buildAndOpenWorkspaceTranscript (in category 'toolbuilder') ----- - buildAndOpenWorkspaceTranscript - - | windowSpec builder | - builder := ToolBuilder default. - windowSpec := self buildWindowWith: builder specs: { - (0.0 @ 0.0 corner: 1.0 @ 0.6) -> [self buildCodePaneWith: builder]. - (0.0 @ 0.6 corner: 1.0 @ 1.0) -> [self buildTranscriptWith: builder]. - }. - builder open: windowSpec. - ^ self! Item was removed: - ----- Method: Workspace>>buildCodePaneWith: (in category 'toolbuilder') ----- - buildCodePaneWith: builder - | textSpec | - textSpec := builder pluggableCodePaneSpec new. - textSpec - model: self; - getText: #contents; - setText: #contents:notifying:; - selection: #contentsSelection; - menu: #codePaneMenu:shifted:. - ^textSpec! Item was removed: - ----- Method: Workspace>>buildTranscriptWith: (in category 'toolbuilder') ----- - buildTranscriptWith: builder - - | textSpec | - textSpec := builder pluggableTextSpec new. - textSpec - model: Transcript; - menu: #codePaneMenu:shifted:. - ^ textSpec! Item was removed: - ----- Method: Workspace>>canStyle (in category 'code pane menu') ----- - canStyle - - ^ (TextStyler for: #Smalltalk) notNil! Item was removed: - ----- Method: Workspace>>changeFileName (in category 'menu commands') ----- - changeFileName - "Let the user specify a new file name (and path) for save-contents requests." - - (Project uiManager - saveFilenameRequest: 'Save text contents in file...' - initialAnswer: self suggestedFileNameForSave) - ifNotNil: [:newFileName | - newFileName ifNotEmpty: [self setFileName: newFileName]].! Item was removed: - ----- Method: Workspace>>contents: (in category 'accessing') ----- - contents: textOrString - super contents: textOrString. - self changed: #contents.! Item was removed: - ----- Method: Workspace>>convertToCurrentVersion:refStream: (in category 'object fileIn') ----- - convertToCurrentVersion: varDict refStream: smartRefStrm - - acceptDroppedMorphs ifNil: [acceptDroppedMorphs := false]. - ^super convertToCurrentVersion: varDict refStream: smartRefStrm. - - ! Item was removed: - ----- Method: Workspace>>defaultFileNameForSave (in category 'user edits') ----- - defaultFileNameForSave - "Overwritten to combine selected properties. Also see FileList >> #viewContentsInWorkspace to understand where different directories might originate." - - ^ self fileDirectory fullNameFor: self windowTitle! Item was removed: - ----- Method: Workspace>>environment (in category 'accessing') ----- - environment - ^ environment ifNil: [Smalltalk globals]! Item was removed: - ----- Method: Workspace>>environment: (in category 'accessing') ----- - environment: anEnvironment - - environment := anEnvironment.! Item was removed: - ----- Method: Workspace>>expressionEvaluated:result: (in category 'menu commands') ----- - expressionEvaluated: anExpression result: anObject - - self changed: #style! Item was removed: - ----- Method: Workspace>>fileDirectory (in category 'accessing') ----- - fileDirectory - "Answer the current directory for save-contents requests." - - ^ fileDirectory ifNil: [FileDirectory default]! Item was removed: - ----- Method: Workspace>>fileDirectory: (in category 'accessing') ----- - fileDirectory: aDirectory - "Do not save the default directory so that the image and its surrounding files can be moved across the disk." - - fileDirectory := aDirectory = FileDirectory default ifFalse: [aDirectory].! Item was removed: - ----- Method: Workspace>>fileLineEndConvention (in category 'accessing') ----- - fileLineEndConvention - - ^ fileLineEndConvention! Item was removed: - ----- Method: Workspace>>fileLineEndConvention: (in category 'accessing') ----- - fileLineEndConvention: aSymbol - "#cr, #lf, #crlf -- 'nil' means Squeak's default" - - fileLineEndConvention := aSymbol.! Item was removed: - ----- Method: Workspace>>hasBindingOf: (in category 'binding') ----- - hasBindingOf: aString - ^bindings includesKey: aString! Item was removed: - ----- Method: Workspace>>initialExtent (in category 'initialize-release') ----- - initialExtent - "Start small. Window aspect ratio is 5 sqrt::1 . Good asthetics. -wiz" - - ^ 447 at 200! Item was removed: - ----- Method: Workspace>>initialize (in category 'initialize-release') ----- - initialize - - super initialize. - self resetBindings. - acceptDroppedMorphs := false. - mustDeclareVariables := self class declareVariablesAutomatically not. - environment := Environment current! Item was removed: - ----- Method: Workspace>>inspectBindings (in category 'binding') ----- - inspectBindings - - bindings inspect! Item was removed: - ----- Method: Workspace>>lookupInPools: (in category 'binding') ----- - lookupInPools: aString - "Iterate through all of the lookup pools to find a match for the specified name." - LookupPools ifNil: [^nil]. - LookupPools do: [:pool | (pool bindingOf: aString) ifNotNil: [:assoc | ^assoc value]]. - ^nil - ! Item was removed: - ----- Method: Workspace>>mustDeclareVariableWording (in category 'variable declarations') ----- - mustDeclareVariableWording - - ^(mustDeclareVariables - ifFalse: ['<yes> automatically create variable declaration'] - ifTrue: ['<no> automatically create variable declaration']) translated! Item was removed: - ----- Method: Workspace>>mustDeclareVariables: (in category 'accessing') ----- - mustDeclareVariables: aBoolean - - mustDeclareVariables := aBoolean! Item was removed: - ----- Method: Workspace>>resetBindings (in category 'binding') ----- - resetBindings - - bindings := Dictionary new.! Item was removed: - ----- Method: Workspace>>saveContents:onFileNamed:accessMode: (in category 'user edits') ----- - saveContents: stringContents onFileNamed: fileName accessMode: accessMode - "Overwritten to set conversion rule of line-end character. See FileList >> #viewContentsInWorkspace." - - ^ self - saveContents: stringContents - onFileNamed: fileName - accessMode: accessMode - workBlock: [:fileStream | - fileStream - lineEndConvention: self fileLineEndConvention; - nextPutAll: stringContents]! Item was removed: - ----- Method: Workspace>>saveContents:onFileNamed:accessMode:workBlock: (in category 'user edits') ----- - saveContents: stringContents onFileNamed: fileName accessMode: accessMode workBlock: workBlock - "Overwritten to update #fileDirectory property and #windowTitle on success." - - ^ (super - saveContents: stringContents - onFileNamed: fileName - accessMode: accessMode - workBlock: workBlock) - ifFalse: [false "no success"] - ifTrue: [self setFileName: fileName. true "success"]! Item was removed: - ----- Method: Workspace>>saveContentsInFile (in category 'menu commands') ----- - saveContentsInFile - "Save the view's current contents in a file. Dispatch goes through the view (or morph). See commentary in and senders of #saveContents:accessMode:." - - self changed: #saveContents.! Item was removed: - ----- Method: Workspace>>saveContentsInFileOnAccept (in category 'menu commands') ----- - saveContentsInFileOnAccept - "Arrange that the contents will be saved to a file on each save (or accept). Replace any existing file contents." - - self flag: #discuss. "mt: Is it 'onFile' or rather 'inFile'? Note that there are different access modes." - - self appendContentsToFileOnAcceptEnabled - ifTrue: [(Project uiManager confirm: 'Do you really want to change file access mode\from #append to #update?\\You might lose data when accepting changes.' translated withCRs) - ifFalse: [^ self]]. - - self acceptAction: (self saveContentsInFileOnAcceptEnabled - ifFalse: [ [:stringToSave | | fileName | - "Ensure to compute fileName as late as possible to consider recent changes of the #windowTitle." - fileName := self suggestedFileNameForSave. - - ((FileDirectory forFileName: fileName) fileExists: fileName) - ifFalse: [ "If the default file name, which is derived from the current window title, does not exist, ask the user once to confirm the location." - self - saveContents: stringToSave - accessMode: #create] - ifTrue: [ "Update/replace the contents in the existing file." - self - saveContents: stringToSave - onFileNamed: fileName - accessMode: #update]] ]).! Item was removed: - ----- Method: Workspace>>saveContentsInFileOnAcceptEnabled (in category 'menu commands') ----- - saveContentsInFileOnAcceptEnabled - - ^ (acceptAction notNil and: [acceptAction home selector = #saveContentsInFileOnAccept])! Item was removed: - ----- Method: Workspace>>saveContentsInFileOnAcceptWording (in category 'menu commands') ----- - saveContentsInFileOnAcceptWording - - ^ (self saveContentsInFileOnAcceptEnabled - ifTrue: ['<yes> save contents to {1} on accept'] - ifFalse: ['<no> save contents to {1} on accept']) translated - format: { self suggestedFileNameForSave contractTo: 32 }! Item was removed: - ----- Method: Workspace>>setBindings: (in category 'accessing') ----- - setBindings: aDictionary - "Sets the Workspace to use the specified dictionary as its namespace" - - bindings := aDictionary. - ! Item was removed: - ----- Method: Workspace>>setFileName: (in category 'initialize-release') ----- - setFileName: fileName - - | directory | - directory := FileDirectory forFileName: fileName. - self fileDirectory: directory. - self windowTitle: (directory localNameFor: fileName).! Item was removed: - ----- Method: Workspace>>setWindowTitle: (in category 'initialize-release') ----- - setWindowTitle: aString - "Normalize window title to not expose file extension in regular workspaces. Do not tell the UI to avoid endless recursion; see #windowTitle: and #windowReqNewLabel:." - - | normalizedTitle | - normalizedTitle := ((aString includesSubstring: 'Workspace') and: [aString endsWithAnyOf: #('.text' '.txt')]) - ifTrue: [aString copyFrom: 1 to: (aString lastIndexOf: $.) - 1] - ifFalse: [aString]. - - windowTitle := normalizedTitle.! Item was removed: - ----- Method: Workspace>>shouldStyle (in category 'code pane menu') ----- - shouldStyle - - ^shouldStyle ifNil: [ self class shouldStyle ]! Item was removed: - ----- Method: Workspace>>shouldStyle: (in category 'code pane menu') ----- - shouldStyle: aBool - "If true, contents will by rendered w/ syntax-highlighting" - - shouldStyle := aBool! Item was removed: - ----- Method: Workspace>>spawn: (in category '*Tools') ----- - spawn: contentsString - - UIManager default edit: contentsString label: 'Workspace' shouldStyle: self shouldStyle! Item was removed: - ----- Method: Workspace>>toggleDroppingMorphForReference (in category 'drag and drop') ----- - toggleDroppingMorphForReference - - acceptDroppedMorphs := acceptDroppedMorphs not. - - ! Item was removed: - ----- Method: Workspace>>toggleStyling (in category 'code pane menu') ----- - toggleStyling - - self canStyle ifFalse: [^ self inform: 'No text styler for #Smalltalk configured.']. - shouldStyle := self shouldStyle not. - self changed: #style.! Item was removed: - ----- Method: Workspace>>toggleStylingLabel (in category 'code pane menu') ----- - toggleStylingLabel - - self canStyle - ifFalse: [^ '<off> syntax highlighting (not available)']. - - ^self shouldStyle - ifTrue: [ '<on> syntax highlighting' ] - ifFalse: [ '<off> syntax highlighting' ]! Item was removed: - ----- Method: Workspace>>toggleVariableDeclarationMode (in category 'variable declarations') ----- - toggleVariableDeclarationMode - - mustDeclareVariables := mustDeclareVariables not! Item was removed: - ----- Method: Workspace>>wantsAnnotationPane (in category 'accessing') ----- - wantsAnnotationPane - "We have nothing to annotate" - ^false! Item was removed: - ----- Method: Workspace>>wantsDroppedMorph:event:inMorph: (in category 'drag and drop') ----- - wantsDroppedMorph: dropee event: evt inMorph: target - - ^ acceptDroppedMorphs or: [dropee isTransferMorph] - - ! Item was removed: - ----- Method: Workspace>>wantsOptionalButtons (in category 'accessing') ----- - wantsOptionalButtons - "We have no optional buttons (yet)" - ^false! Item was removed: - ----- Method: Workspace>>windowReqNewLabel: (in category 'user edits') ----- - windowReqNewLabel: newLabel - "The user has edited the window label. Remember for a later save-to-file request. See #defaultFileNameForSave." - - self setWindowTitle: newLabel. - ^ true! Item was removed: - ----- Method: Workspace>>windowTitle (in category 'accessing') ----- - windowTitle - - ^ windowTitle ifNil: ['Workspace']! Item was removed: - ----- Method: Workspace>>windowTitle: (in category 'accessing') ----- - windowTitle: aString - - self setWindowTitle: aString. - self changed: #windowTitle.! Item was removed: - (PackageInfo named: 'Tools') postscript: 'ToolIcons icons removeKey: #font ifAbsent: []. - - "Update description of the preference #extraDebuggerButtons (Tools-ct.1128)" - (Preferences preferenceAt: #extraDebuggerButtons) instVarNamed: ''helpString'' put: ''If true, debugger windows will show *two* rows of buttons -- the debugger-specific row (proceed, restart, etc.) and also the conventional code-tools row. This preference overrides the "Optional buttons" preference for debuggers.''.'!
More information about the Squeak-dev mailing list |