The Trunk: Tools-nice.151.mcz
Locked
 
|
Nicolas Cellier uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-nice.151.mcz ==================== Summary ==================== Name: Tools-nice.151 Author: nice Time: 27 December 2009, 3:34:27 am UUID: a4e5ff96-0f2c-4d7e-bca4-cc86fce42a0b Ancestors: Tools-nice.150 Cosmetic: move or remove a few temps inside closures =============== Diff against Tools-nice.150 =============== Item was changed: ----- Method: Debugger>>buildNotifierWith:label:message: (in category 'toolbuilder') ----- buildNotifierWith: builder label: label message: messageString + | windowSpec listSpec textSpec panelSpec quads | - | windowSpec listSpec textSpec panelSpec buttonSpec quads | windowSpec := builder pluggableWindowSpec new. windowSpec model: self. windowSpec extent: 450 @ 156. "nice and wide to show plenty of the error msg" windowSpec label: label. windowSpec 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' } ]. + quads do:[:spec| | buttonSpec | - quads do:[:spec| buttonSpec := builder pluggableButtonSpec new. buttonSpec model: self. buttonSpec label: spec first. buttonSpec action: spec second. buttonSpec help: spec fourth. panelSpec children add: buttonSpec. ]. panelSpec layout: #horizontal. "buttons" panelSpec frame: (0@0 corner: 1@0.2). windowSpec children add: panelSpec. Preferences eToyFriendly | messageString notNil ifFalse:[ listSpec := builder pluggableListSpec new. listSpec model: self; list: #contextStackList; getIndex: #contextStackIndex; setIndex: #debugAt:; frame: (0@0.2 corner: 1@1). windowSpec children add: listSpec. ] ifTrue:[ message := messageString. textSpec := builder pluggableTextSpec new. textSpec model: self; getText: #preDebugMessageString; setText: nil; selection: nil; menu: #debugProceedMenu:; frame: (0@0.2corner: 1@1). windowSpec children add: textSpec. ]. ^windowSpec! Item was changed: ----- Method: ArchiveViewer>>createButtonBar (in category 'initialization') ----- createButtonBar + | bar narrowFont registeredFonts | - | bar button narrowFont registeredFonts | registeredFonts := OrderedCollection new. TextStyle knownTextStylesWithoutDefault do: [:st | (TextStyle named: st) fonts do: [:f | registeredFonts addLast: f]]. narrowFont := registeredFonts detectMin: [:ea | ea widthOfString: 'Contents' from: 1 to: 8]. bar := AlignmentMorph newRow. bar color: self defaultBackgroundColor; rubberBandCells: false; vResizing: #shrinkWrap; cellInset: 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 As' #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 from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #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\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) do: [:arr | + | buttonLabel button | - | buttonLabel | buttonLabel := (TextMorph new) string: arr first withCRs fontName: narrowFont familyName size: narrowFont pointSize wrap: false; hResizing: #shrinkWrap; lock; yourself. (button := PluggableButtonMorph on: self getState: arr second action: arr third) vResizing: #shrinkWrap; hResizing: #spaceFill; onColor: self buttonOnColor offColor: self buttonOffColor; label: buttonLabel; setBalloonText: arr fourth. bar addMorphBack: button. buttonLabel composeToBounds]. ^bar! Item was changed: ----- 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 | - | cm | - self filterFrom: [:aClass :aSelector | (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 changed: ----- Method: MessageSet>>filterToNotCurrentAuthor (in category 'filtering') ----- filterToNotCurrentAuthor "Filter down only to messages not stamped with my initials" + | myInitials | - | myInitials aMethod aTimeStamp | (myInitials := Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. self filterFrom: + [:aClass :aSelector | | aTimeStamp aMethod | - [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]. aMethod notNil and: [(aTimeStamp := Utilities timeStampForMethod: aMethod) isNil or: [(aTimeStamp beginsWith: myInitials) not]]]]! Item was changed: ----- Method: ChangeList>>removeOlderMethodVersions (in category 'menu actions') ----- removeOlderMethodVersions "Remove older versions of entries from the receiver." + | newChangeList newList found | - | newChangeList newList found str | newChangeList := OrderedCollection new. newList := OrderedCollection new. found := OrderedCollection new. changeList reverseWith: list do: + [:chRec :strNstamp | | str | str := strNstamp copyUpTo: $;. - [:chRec :strNstamp | 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 changed: ----- Method: IndentingListItemMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas + | tRect sRect columnScanner columnLeft | - | tRect sRect columnRect columnScanner columnData columnLeft | tRect := self toggleRectangle. sRect := bounds withLeft: tRect right + 4. self drawToggleOn: aCanvas in: tRect. icon isNil ifFalse:[ aCanvas translucentImage: icon at: sRect left @ (self top + (self height - icon height // 2)). sRect := sRect left: sRect left + icon width + 2. ]. (container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [ sRect := sRect top: sRect top + sRect bottom - self fontToUse height // 2. aCanvas drawString: contents asString in: sRect font: self fontToUse color: color. ] ifFalse: [ columnLeft := sRect left. columnScanner := ReadStream on: contents asString. + container columns do: [ :width | | columnRect columnData | - container columns do: [ :width | columnRect := columnLeft @ sRect top extent: width @ sRect height. columnData := columnScanner upTo: Character tab. columnData isEmpty ifFalse: [ aCanvas drawString: columnData in: columnRect font: self fontToUse color: color . ]. columnLeft := columnRect right + 5. ]. ] ! Item was changed: ----- Method: FileContentsBrowser class>>browseCompressedCodeStream: (in category 'instance creation') ----- browseCompressedCodeStream: aStandardFileStream "Browse the selected file in fileIn format." + | unzipped | + [ | zipped |zipped := GZipReadStream on: aStandardFileStream. - | zipped unzipped | - [zipped := GZipReadStream on: aStandardFileStream. unzipped := MultiByteBinaryOrTextStream with: zipped contents asString] ensure: [aStandardFileStream close]. unzipped reset. self browseStream: unzipped named: aStandardFileStream name! Item was changed: ----- Method: Lexicon>>selectorsSendingSelectedSelector (in category 'senders') ----- selectorsSendingSelectedSelector "Assumes lastSendersSearchSelector is already set" + | selectorSet | - | selectorSet sel cl | autoSelectString := (self lastSendersSearchSelector upTo: $:) asString. selectorSet := Set new. (self systemNavigation allCallsOn: self lastSendersSearchSelector) + do: [:anItem | | sel cl | - do: [:anItem | sel := anItem methodSymbol. cl := anItem actualClass. ((currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass) and: [targetClass includesBehavior: cl]) ifTrue: [selectorSet add: sel]]. ^ selectorSet asSortedArray! Item was changed: ----- Method: MessageSet>>selectedMessage (in category 'contents') ----- selectedMessage "Answer the source method for the currently selected message." + + self setClassAndSelectorIn: [:class :selector | | source | - | source | - self setClassAndSelectorIn: [:class :selector | class ifNil: [^ 'Class vanished']. selector first isUppercase ifTrue: [selector == #Comment ifTrue: [currentCompiledMethod := class organization commentRemoteStr. ^ class comment]. selector == #Definition ifTrue: [^ class definitionST80]. 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 changed: ----- Method: VersionsBrowser>>versionFrom: (in category 'menu') ----- versionFrom: secsSince1901 + - | strings vTime | "Return changeRecord of the version in effect at that time. Accept in the VersionsBrowser does not use this code." + changeList do: [:cngRec | | vTime strings | - changeList do: [:cngRec | (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 changed: ----- Method: SelectorBrowser>>quickList (in category 'as yet unclassified') ----- 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 result resultArray newExp dataStrings mf dataObjects aa statements | data := contents asString. "delete t railing period. This should be fixed in the Parser!!" [data last isSeparator] whileTrue: [data := data allButLast]. data last = $. ifTrue: [data := data allButLast]. "Eval" 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 | - [resultArray := resultArray collect: [:expression | newExp := expression. dataObjects first withIndexDo: [:lit :i | newExp := newExp copyReplaceAll: 'data', i printString with: (dataStrings at: i)]. newExp, ' --> ', dataStrings last]]. ^ resultArray! Item was changed: ----- Method: ChangeList>>selectNewMethods (in category 'menu actions') ----- selectNewMethods "Selects all method definitions for which there is no counterpart method in the current image" + - | change class | Cursor read showWhile: + [ | change class |1 to: changeList size do: - [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 changed: ----- Method: ChangeList class>>browseCompressedChangesFile: (in category 'fileIn/Out') ----- browseCompressedChangesFile: fullName "Browse the selected file in fileIn format." + | unzipped stream | - | zipped unzipped stream | fullName ifNil: [^Beeper beep]. stream := FileStream readOnlyFileNamed: fullName. + [ | zipped |stream converter: Latin1TextConverter new. - [stream converter: Latin1TextConverter new. zipped := GZipReadStream on: stream. unzipped := zipped contents asString] ensure: [stream close]. stream := (MultiByteBinaryOrTextStream with: unzipped) reset. ChangeList browseStream: stream! Item was changed: ----- 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." + - | aClass aChange | Cursor read showWhile: + [ | aClass aChange |1 to: changeList size do: - [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 changed: ----- Method: Lexicon>>buildCustomButtonsWith: (in category 'toolbuilder') ----- buildCustomButtonsWith: builder "This method if very similar to StringHolder>>buildOptionalButtonsWith:. Refactor and pass in button specs?" + | panelSpec | - | panelSpec buttonSpec | panelSpec := builder pluggablePanelSpec new. panelSpec children: OrderedCollection new. + self customButtonSpecs do: [:spec | | buttonSpec | - self customButtonSpecs do: [:spec | buttonSpec := builder pluggableActionButtonSpec new. buttonSpec model: self. buttonSpec label: spec first. buttonSpec action: spec second. spec size > 2 ifTrue: [buttonSpec help: spec third]. panelSpec children add: buttonSpec. ]. panelSpec layout: #horizontal. "buttons" self addSpecialButtonsTo: panelSpec with: builder. ^panelSpec! Item was changed: ----- Method: MessageSet>>sortByDate (in category 'message list') ----- sortByDate "Sort the message-list by date of time-stamp" + | assocs inOrder | - | assocs aCompiledMethod aDate inOrder | assocs := messageList collect: + [:aRef | | aDate aCompiledMethod | - [:aRef | 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" inOrder := assocs asSortedCollection: [:a :b | a value < b value]. messageList := inOrder asArray collect: [:assoc | assoc key]. self changed: #messageList! Item was changed: ----- 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" + | systemChanges | - | change class systemChanges | Cursor read showWhile: + [ | change class |(changeSetOrList isKindOf: ChangeSet) ifTrue: [ - [(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 changed: ----- 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." + - | cm | self filterFrom: + [:aClass :aSelector | | cm | - [:aClass :aSelector | 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 changed: ----- 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 inputWithBlanksTrimmed aMethod | aFragment := UIManager default request: 'type selector:' initialAnswer: ''. aFragment isEmptyOrNil ifTrue: [^ self]. inputWithBlanksTrimmed := aFragment withBlanksTrimmed. Symbol hasInterned: inputWithBlanksTrimmed ifTrue: [:aSymbol | self filterFrom: + [:aClass :aSelector | | aMethod | - [:aClass :aSelector | (aMethod := aClass compiledMethodAt: aSelector) isNil or: [(aMethod hasLiteralThorough: aSymbol) not]]]! Item was changed: ----- Method: ClassCommentVersionsBrowser class>>browseCommentOf: (in category 'instance creation') ----- browseCommentOf: class - | changeList | Cursor read showWhile: + [| changeList | + changeList := self new scanVersionsOf: class. - [changeList := self new scanVersionsOf: class. changeList ifNil: [^ self inform: 'No versions available']. self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ] ! Item was changed: ----- Method: Lexicon>>initListFrom:highlighting: (in category 'initialization') ----- initListFrom: selectorCollection highlighting: aClass "Make up the messageList with items from aClass in boldface. Provide a final filtering in that only selectors whose implementations fall within my limitClass will be shown." + - | defClass item | messageList := OrderedCollection new. selectorCollection do: + [:selector | | item defClass | defClass := aClass whichClassIncludesSelector: selector. - [:selector | defClass := aClass whichClassIncludesSelector: selector. (defClass notNil and: [defClass includesBehavior: self limitClass]) ifTrue: [item := selector, ' (' , defClass name , ')'. item := item asText. defClass == aClass ifTrue: [item allBold]. "(self isThereAnOverrideOf: selector) ifTrue: [item addAttribute: TextEmphasis struckOut]." "The above has a germ of a good idea but could be very slow" messageList add: item]]! Item was changed: ----- Method: SelectorBrowser>>testObjects:strings: (in category 'as yet unclassified') ----- testObjects: dataObjects strings: dataStrings + | dataObjs dataStrs selectors classes didUnmodifiedAnswer | - | dataObjs dataStrs selectors classes didUnmodifiedAnswer answerMod do ds result ddo dds | "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" - selectors withIndexDo: [:ansSel :ansInd | "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" - selectors allButLast withIndexDo: [:argSel :argInd | "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 changed: ----- Method: ChangeList>>scanFile:from:to: (in category 'scanning') ----- scanFile: aFile from: startPosition to: stopPosition + - | itemPosition item prevChar | file := aFile. changeList := OrderedCollection new. list := OrderedCollection new. listIndex := 0. file position: startPosition. 'Scanning ', aFile localName, '...' displayProgressAt: Sensor cursorPoint from: startPosition to: stopPosition + during: [:bar | | prevChar itemPosition item | - during: [:bar | [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: [self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) text: 'do it: ' , (item contractTo: 50)]]]]. listSelections := Array new: list size withAll: false! Item was changed: ----- Method: PackagePaneBrowser>>packageList (in category 'package list') ----- packageList "Answer a list of the packages in the current system organization." + | str stream | - | str cats stream | str := Set new: 100. stream := WriteStream on: (Array new: 100). systemOrganizer categories do: + [ :categ | | cats | - [ :categ | cats := categ asString copyUpTo: $-. (str includes: cats) ifFalse: [str add: cats. stream nextPut: cats]]. ^stream contents! Item was changed: ----- Method: ChangeList>>selectConflicts (in category 'menu actions') ----- selectConflicts "Selects all method definitions for which there is ALSO an entry in changes" + - | change class | Cursor read showWhile: + [ | change class |1 to: changeList size do: - [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 changed: ----- Method: Model>>addItem: (in category '*Tools') ----- addItem: classAndMethod "Make a linked message list and put this method in it" + - | list | self flag: #mref. "classAndMethod is a String" MessageSet parse: classAndMethod + toClassAndSelector: [ :class :sel | | list | - toClassAndSelector: [ :class :sel | class ifNil: [^self]. list := OrderedCollection with: ( MethodReference new setClass: class methodSymbol: sel stringVersion: classAndMethod ). MessageSet openMessageList: list name: 'Linked by HyperText'. ] ! Item was changed: ----- Method: FileContentsBrowser class>>browseStream:named: (in category 'instance creation') ----- browseStream: aStream named: aString + | browser | + Cursor wait showWhile: [ | package packageDict organizer | - | package organizer packageDict browser | - Cursor wait showWhile: [ packageDict := Dictionary new. browser := self new. organizer := SystemOrganizer defaultList: Array new. package := (FilePackage new fullName: aString; fileInFrom: aStream). packageDict at: package packageName put: package. organizer classifyAll: package classes keys under: package packageName. (browser := self systemOrganizer: organizer) packages: packageDict]. self openBrowserView: browser createViews label: 'File Contents Browser'. ! Item was changed: ----- 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." + - | s | messageList := OrderedCollection new. anArray do: [ :each | MessageSet parse: each + toClassAndSelector: [ :class :sel | | s | - toClassAndSelector: [ :class :sel | class ifNotNil: [class isUniClass ifTrue: [s := class typicalInstanceName, ' ', sel] ifFalse: [s := class name , ' ' , sel , ' {' , ((class organization categoryOfElement: sel) ifNil: ['']) , '}']. messageList add: ( MethodReference new setClass: class methodSymbol: sel stringVersion: s)]]]. messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1]. contents := ''! Item was changed: ----- Method: FileContentsBrowser class>>browseFiles: (in category 'instance creation') ----- browseFiles: fileList + | browser | + Cursor wait showWhile: [ | organizer packageDict | - | package organizer packageDict browser | - Cursor wait showWhile: [ packageDict := Dictionary new. organizer := SystemOrganizer defaultList: Array new. + fileList do: [:fileName | | package | - fileList do: [:fileName | package := FilePackage fromFileNamed: fileName. packageDict at: package packageName put: package. organizer classifyAll: package classes keys under: package packageName]. (browser := self systemOrganizer: organizer) packages: packageDict]. self openBrowserView: browser createViews label: 'File Contents Browser'. ! Item was changed: ----- 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 inputWithBlanksTrimmed aMethod | aFragment := UIManager default request: 'type selector:' initialAnswer: ''. aFragment isEmptyOrNil ifTrue: [^ self]. inputWithBlanksTrimmed := aFragment withBlanksTrimmed. Symbol hasInterned: inputWithBlanksTrimmed ifTrue: [:aSymbol | self filterFrom: + [:aClass :aSelector | | aMethod | - [:aClass :aSelector | (aMethod := aClass compiledMethodAt: aSelector) notNil and: [aMethod hasLiteralThorough: aSymbol]]] ! Item was changed: ----- Method: HierarchyBrowser>>initHierarchyForClass: (in category 'initialization') ----- initHierarchyForClass: aClassOrMetaClass + | index nonMetaClass tab | - | tab stab index nonMetaClass | centralClass := aClassOrMetaClass. nonMetaClass := aClassOrMetaClass theNonMetaClass. self systemOrganizer: SystemOrganization. metaClassIndicated := aClassOrMetaClass isMeta. classList := OrderedCollection new. tab := ''. nonMetaClass allSuperclasses reverseDo: [:aClass | classList add: tab , aClass name. tab := tab , ' ']. index := classList size + 1. nonMetaClass allSubclassesWithLevelDo: + [:aClass :level | | stab | - [:aClass :level | stab := ''. 1 to: level do: [:i | stab := stab , ' ']. classList add: tab , stab , aClass name] startingLevel: 0. self classListIndex: index! Item was changed: ----- 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 | - | stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList | aSelector == #Comment ifTrue: [^ self annotationForClassCommentFor: aClass]. aSelector == #Definition ifTrue: [^ self annotationForClassDefinitionFor: aClass]. aSelector == #Hierarchy ifTrue: [^ self annotationForHierarchyFor: aClass]. aStream := ReadWriteStream on: ''. requestList := self annotationRequests. separator := requestList size > 1 ifTrue: [self annotationSeparator] ifFalse: ['']. requestList + do: [:aRequest | | aString sendersCount aComment aCategory implementorsCount aList stamp | - do: [:aRequest | aRequest == #firstComment ifTrue: [aComment := aClass firstCommentAt: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #masterComment ifTrue: [aComment := aClass supermostPrecodeCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #documentation ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #timeStamp ifTrue: [stamp := self timeStamp. aStream nextPutAll: (stamp size > 0 ifTrue: [stamp , separator] ifFalse: ['no timeStamp' , 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 , separator]]. aRequest == #sendersCount ifTrue: [sendersCount := (self systemNavigation allCallsOn: aSelector) size. sendersCount := sendersCount == 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString , ' senders']. aStream nextPutAll: sendersCount , separator]. aRequest == #implementorsCount ifTrue: [implementorsCount := self systemNavigation numberOfImplementorsOf: aSelector. implementorsCount := implementorsCount == 1 ifTrue: ['1 implementor'] ifFalse: [implementorsCount printString , ' implementors']. aStream nextPutAll: implementorsCount , 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: ' , stamp , separator]]. aRequest == #recentChangeSet ifTrue: [aString := ChangesOrganizer mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. aString size > 0 ifTrue: [aStream nextPutAll: aString , 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]]. ^ aStream contents! Item was changed: ----- Method: TimeProfileBrowser>>setClassAndSelectorIn: (in category 'private') ----- setClassAndSelectorIn: csBlock "Decode strings of the form <selectorName> (<className> [class]) " - | string strm class sel parens | - self flag: #mref. "fix for faster references to methods" + + [ | strm string class parens sel | + string := self selection asString. - - [string := self selection asString. string first == $* ifTrue: [^contents := nil]. "Ignore lines starting with *" parens := string includes: $(. "Does it have open-paren?" strm := ReadStream on: string. parens ifTrue: [strm skipTo: $(. "easy case" class := strm upTo: $). strm next: 2. sel := strm upToEnd] ifFalse: [strm position: (string findString: ' class>>'). strm position > 0 ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])] ifTrue: [ | subString | "find the next to last space character" subString := strm contents copyFrom: 1 to: (string findLast: [ :ch | ch == $ ]) - 1. strm position: (subString findLast: [ :ch | ch == $ ])]. "ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])." class := strm upTo: $>. strm next. sel := strm upToEnd]. ^ MessageSet parse: (class, ' ', sel) toClassAndSelector: csBlock] on: Error do: [:ex | ^ contents := nil]! Item was changed: ----- Method: MessageSet>>filterToCurrentAuthor (in category 'filtering') ----- filterToCurrentAuthor "Filter down only to messages with my initials as most recent author" + | myInitials | - | myInitials aMethod aTimeStamp | (myInitials := Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. self filterFrom: + [:aClass :aSelector | | aMethod aTimeStamp | - [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]. aMethod notNil and: [(aTimeStamp := Utilities timeStampForMethod: aMethod) notNil and: [aTimeStamp beginsWith: myInitials]]]]! Item was changed: ----- Method: Lexicon>>selectorsChanged (in category 'within-tool queries') ----- selectorsChanged "Return a list of methods in the current change set (or satisfying some other such criterion) that are in the protocol of this object" + | aList targetedClass | - | aList aClass targetedClass | targetedClass := self targetObject ifNil: [targetClass] ifNotNil: [self targetObject class]. aList := OrderedCollection new. ChangeSet current methodChanges associationsDo: [:classChgAssoc | classChgAssoc value + associationsDo: [:methodChgAssoc | | aClass | (methodChgAssoc value == #change - associationsDo: [:methodChgAssoc | (methodChgAssoc value == #change or: [methodChgAssoc value == #add]) ifTrue: [(aClass := targetedClass whichClassIncludesSelector: methodChgAssoc key) ifNotNil: [aClass name = classChgAssoc key ifTrue: [aList add: methodChgAssoc key]]]]]. ^ aList! Item was changed: ----- 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 menuIndex oldIndex newName | - | labels reject lines cats menuIndex oldIndex newName | self okToChange ifFalse: [^ self]. classListIndex = 0 ifTrue: [^ self]. labels := OrderedCollection with: 'new...'. reject := Set new. reject addAll: self selectedClassOrMetaClass organization categories; add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines := OrderedCollection new. + self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - self selectedClassOrMetaClass allSuperclasses do: [:cls | cls = Object ifFalse: [ cats := cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [ lines add: labels size. labels addAll: cats asSortedCollection. reject addAll: cats]]]. newName := (labels size = 1 or: [ menuIndex := (UIManager default chooseFrom: labels lines: lines title: 'Add Category'). menuIndex = 0 ifTrue: [^ self]. menuIndex = 1]) ifTrue: [ self request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [ labels at: menuIndex]. oldIndex := messageCategoryListIndex. newName isEmpty ifTrue: [^ self] ifFalse: [newName := newName asSymbol]. self classOrMetaClassOrganizer addCategory: newName before: (messageCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedMessageCategoryName]). self changed: #messageCategoryList. self messageCategoryListIndex: (oldIndex = 0 ifTrue: [self classOrMetaClassOrganizer categories size + 1] ifFalse: [oldIndex]). self changed: #messageCategoryList. ! Item was changed: ----- Method: TimeProfileBrowser>>selectedMessage (in category 'message list') ----- selectedMessage "Answer the source method for the currently selected message." + - | source | self setClassAndSelectorIn: + [:class :selector | | source | - [:class :selector | source := class sourceMethodAt: selector ifAbsent: [^'Missing']. Preferences browseWithPrettyPrint ifTrue: [source := class prettyPrinterClass format: source in: class notifying: nil decorated: false]. self selectedClass: class. self selectedSelector: selector. ^source asText makeSelectorBoldIn: class]. ^''! Item was changed: ----- 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" + - | change class | Cursor read showWhile: + [ | class change |1 to: changeList size do: - [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 changed: ----- 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 aChangeSet infoString empty | notFound := OrderedCollection new. empty := OrderedCollection new. nameList do: + [:aName | | aChangeSet | (aChangeSet := self changeSetNamed: aName) - [:aName | (aChangeSet := self changeSetNamed: aName) ifNotNil: [aChangeSet isEmpty ifTrue: [empty add: aName] ifFalse: [aChangeSet fileOut]] ifNil: [notFound add: aName]]. infoString := (nameList size - notFound size) printString, ' change set(s) filed out'. notFound size > 0 ifTrue: [infoString := infoString, ' ', notFound size printString, ' change set(s) not found:'. notFound do: [:aName | infoString := infoString, ' ', aName]]. empty size > 0 ifTrue: [infoString := infoString, ' ', empty size printString, ' change set(s) were empty:'. empty do: [:aName | infoString := infoString, ' ', aName]]. self inform: infoString! |
«
Return to Squeak - Dev
|
1 view|%1 views
| Free forum by Nabble | Edit this page |