--- a/CBrowser.st Mon Oct 10 04:15:21 1994 +0100
+++ b/CBrowser.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,8 +1,6 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -12,22 +10,22 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.3 on 26-sep-1994 at 1:19:22 pm'!
+
StandardSystemView subclass:#ChangesBrowser
- instanceVariableNames:'changeListView codeView changeFileName
- changeChunks changePositions
- changeClassNames changeHeaderLines
- anyChanges changeNrShown changeNrProcessed
- fileBox'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'changeListView codeView changeFileName changeChunks
+ changePositions changeClassNames changeHeaderLines anyChanges
+ changeNrShown changeNrProcessed fileBox skipSignal'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
ChangesBrowser comment:'
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.15 1994-08-22 18:06:51 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.16 1994-10-10 03:15:12 claus Exp $
'!
!ChangesBrowser class methodsFor:'documentation'!
@@ -35,7 +33,7 @@
copyright
"
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -48,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.15 1994-08-22 18:06:51 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.16 1994-10-10 03:15:12 claus Exp $
"
!
@@ -61,6 +59,21 @@
"
! !
+!ChangesBrowser class methodsFor:'instance creation'!
+
+new
+ "create a new changes browser"
+
+ ^ super label:'Changes Browser'
+ icon:(Form fromFile:'CBrowser.xbm' resolution:100)
+!
+
+openOn:aFileName
+ "create c changes browser on a change file"
+
+ ^ ((self new label:'Changes Browser:', aFileName) changeFileName:aFileName) open
+! !
+
!ChangesBrowser class methodsFor:'behavior'!
autoSelectNext
@@ -70,23 +83,67 @@
^ true
! !
-!ChangesBrowser class methodsFor:'instance creation'!
+!ChangesBrowser methodsFor:'initialize / release'!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#(
+ 'apply change'
+ 'apply changes to end'
+ 'apply all changes'
+ '-'
+ 'delete'
+ 'delete to end'
+ 'delete changes for this class to end'
+ 'delete all changes for this class'
+ '-'
+ 'update'
+ 'compress'
+ 'compare with current version'
+ 'browse class'
+ '-'
+ 'make change a patch'
+"/ 'update sourcefile from change'
+"/ '-'
+ 'save change in file ...'
+ 'save changes to end in file ...'
+ 'save changes for this class to end in file ...'
+ 'save all changes for this class in file ...'
+ '-'
+ 'writeback changeFile').
-new
- "create a new changes browser"
-
- ^ super label:'Changes Browser'
- icon:(Form fromFile:'CBrowser.xbm' resolution:100)
+ changeListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ doApply
+ doApplyRest
+ doApplyAll
+ nil
+ doDelete
+ doDeleteRest
+ doDeleteClassRest
+ doDeleteClassAll
+ nil
+ doUpdate
+ doCompress
+ doCompare
+ doBrowse
+ nil
+ doMakePatch
+"/ doMakePermanent
+"/ nil
+ doSave
+ doSaveRest
+ doSaveClassRest
+ doSaveClassAll
+ nil
+ doWriteBack)
+ receiver:self
+ for:changeListView)
!
-openOn:aFileName
- "create c changes browser on a change file"
-
- ^ ((self new label:'Changes Browser:', aFileName) changeFileName:aFileName) open
-! !
-
-!ChangesBrowser methodsFor:'initialize / release'!
-
initialize
|frame v|
@@ -95,9 +152,9 @@
changeFileName := 'changes'.
frame := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- borderWidth:0
- in:self.
+ corner:(1.0 @ 1.0)
+ borderWidth:0
+ in:self.
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.3).
@@ -112,63 +169,6 @@
ObjectMemory addDependent:self. "to get shutdown-update"
!
-initializeMiddleButtonMenu
- |labels|
-
- labels := resources array:#(
- 'apply change'
- 'apply changes to end'
- 'apply all changes'
- '-'
- 'delete'
- 'delete to end'
- 'delete changes for this class to end'
- 'delete all changes for this class'
- '-'
- 'update'
- 'compress'
- 'compare with current version'
- '-'
- 'make change a patch'
-"/ 'update sourcefile from change'
- '-'
- 'save change in file ...'
- 'save changes to end in file ...'
- 'save changes for this class to end in file ...'
- 'save all changes for this class in file ...'
- '-'
- 'writeback changeFile').
-
- changeListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(
- doApply
- doApplyRest
- doApplyAll
- nil
- doDelete
- doDeleteRest
- doDeleteClassRest
- doDeleteClassAll
- nil
- doUpdate
- doCompress
- doCompare
- nil
- doMakePatch
-"/ doMakePermanent
- nil
- doSave
- doSaveRest
- doSaveClassRest
- doSaveClassAll
- nil
- doWriteBack)
- receiver:self
- for:changeListView)
-!
-
realize
super realize.
self readChangesFileInBackground:true.
@@ -181,32 +181,51 @@
|box|
(what == #aboutToExit) ifTrue:[
- "
- smalltalk is about to shut down -
- - if change list was modified, ask user and save if requested.
- "
- anyChanges ifTrue:[
- shown ifFalse:[
- self unrealize.
- self realize
- ].
- self raise.
+ "
+ smalltalk is about to shut down -
+ - if change list was modified, ask user and save if requested.
+ "
+ anyChanges ifTrue:[
+ shown ifFalse:[
+ self unrealize.
+ self realize
+ ].
+ self raise.
- box := YesNoBox new.
- box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
- box noText:(resources at:'don''t update').
- box okText:(resources at:'update').
- box yesAction:[self writeBackChanges]
- noAction:[].
- box showAtPointer
- ].
- ^ self
+ box := YesNoBox new.
+ box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
+ box noText:(resources at:'don''t update').
+ box okText:(resources at:'update').
+ box yesAction:[self writeBackChanges]
+ noAction:[].
+ box showAtPointer
+ ].
+ ^ self
].
super update:what
! !
!ChangesBrowser methodsFor:'termination'!
+terminate
+ "window manager wants us to go away"
+
+ |box|
+
+ anyChanges ifTrue:[
+ box := OptionBox title:'' numberOfOptions:3.
+ box title:(resources at:'close ChangesBrowser.\\changefile has not been updated from the modified changelist.\\Update before closing ?') withCRs.
+ box buttonTitles:(resources array:#('abort' 'don''t update' 'update')).
+ box actions:(Array with:[^ self]
+ with:[self destroy]
+ with:[self writeBackChanges. self destroy]
+ ).
+ box showAtPointer.
+ ] ifFalse:[
+ self destroy
+ ]
+!
+
destroy
"destroy the receiver; make certain, that boxes are destroyed too"
@@ -221,139 +240,13 @@
send it; instead, they simply destroy the view."
anyChanges ifTrue:[
- self writeBackChanges.
+ self writeBackChanges.
].
self destroy
-!
-
-terminate
- "window manager wants us to go away"
-
- |box|
-
- anyChanges ifTrue:[
- box := OptionBox title:'' numberOfOptions:3.
- box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
- box buttonTitles:(resources array:#('abort' 'dont''t update' 'update')).
- box actions:(Array with:[^ self]
- with:[self destroy]
- with:[self writeBackChanges. self destroy]
- ).
- box showAtPointer.
- ] ifFalse:[
- self destroy
- ]
! !
!ChangesBrowser methodsFor:'private'!
-enableMenuEntries
- "enable all entries refering to a selected change"
-
- #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
- doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
- doSave doSaveRest doSaveClassAll doSaveClassRest)
- do:[:sel |
- changeListView middleButtonMenu enable:sel
- ].
-!
-
-disableMenuEntries
- "enable all entries refering to a selected change"
-
- #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
- doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
- doSave doSaveRest doSaveClassAll doSaveClassRest)
- do:[:sel |
- changeListView middleButtonMenu disable:sel
- ].
-!
-
-unselect
- "common unselect"
-
- changeListView deselect.
- self disableMenuEntries
-!
-
-queryCloseText
- "made this a method for easy redefinition in subclasses"
-
- ^ 'Quit without updating changeFile ?'
-!
-
-changeFileName:aFileName
- changeFileName := aFileName
-!
-
-classNameOfChange:changeNr
- "return the classname of a change (for xxx class - changes xxx is returned)
- - since parsing ascii methods is slow, keep result cached in
- changeClassNames for the next query"
-
- |chunk aParseTree recTree sel name arg1Tree|
-
- changeNr notNil ifTrue:[
- "
- first look, if not already known
- "
- name := changeClassNames at:changeNr.
- name notNil ifTrue:[^ name].
-
- "
- get the chunk
- "
- chunk := changeChunks at:changeNr.
- chunk notNil ifTrue:[
- "
- use parser to construct a parseTree
- "
- aParseTree := Parser parseExpression:chunk.
- (aParseTree notNil and:[aParseTree isMessage]) ifTrue:[
- "
- ask parser for selector
- "
- sel := aParseTree selector.
- "
- is it a method-change, methodRemove or comment-change ?
- "
- (#(methodsFor: privateMethodsFor: publicMethodsFor:
- removeSelector: comment:) includes:sel) ifTrue:[
- "
- yes, the className is the receiver
- "
- recTree := aParseTree receiver.
- (recTree notNil and:[recTree ~~ #Error]) ifTrue:[
- recTree isUnaryMessage ifTrue:[
- (recTree selector ~~ #class) ifTrue:[^ nil].
- "id class methodsFor:..."
- recTree := recTree receiver
- ].
- recTree isPrimary ifTrue:[
- name := recTree name.
- changeClassNames at:changeNr put:name.
- ^ name
- ]
- ]
- ] ifFalse:[
- "
- is it a change in a class-description ?
- "
- ('subclass:*' match:sel) ifTrue:[
- arg1Tree := aParseTree arg1.
- (arg1Tree notNil and:[arg1Tree isConstant]) ifTrue:[
- name := arg1Tree value asString.
- changeClassNames at:changeNr put:name.
- ^ name
- ]
- ]
- ]
- ]
- ]
- ].
- ^ nil
-!
-
streamForChange:changeNr
"answer a stream for change"
@@ -365,6 +258,35 @@
^ aStream
!
+enableMenuEntries
+ "enable all entries refering to a selected change"
+
+ #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
+ doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
+ doSave doSaveRest doSaveClassAll doSaveClassRest doBrowse)
+ do:[:sel |
+ changeListView middleButtonMenu enable:sel
+ ].
+!
+
+unselect
+ "common unselect"
+
+ changeListView deselect.
+ self disableMenuEntries
+!
+
+disableMenuEntries
+ "enable all entries refering to a selected change"
+
+ #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
+ doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
+ doSave doSaveRest doSaveClassAll doSaveClassRest doBrowse)
+ do:[:sel |
+ changeListView middleButtonMenu disable:sel
+ ].
+!
+
clearCodeView
self unselect "changeListView deselect".
codeView contents:nil.
@@ -373,83 +295,26 @@
autoSelect:changeNr
self class autoSelectNext ifTrue:[
- (changeNr <= changeChunks size) ifTrue:[
- self clearCodeView.
- changeListView selection:changeNr.
- self changeSelection:changeNr.
- ^ self
- ]
+ (changeNr <= changeChunks size) ifTrue:[
+ self clearCodeView.
+ changeListView selection:changeNr.
+ self changeSelection:changeNr.
+ ^ self
+ ]
].
self clearCodeView
!
-writeBackChanges
- "write back the changes file"
-
- |inStream outStream chunk sawExcla excla done dir|
-
- outStream := FileStream newFileNamed:'n_changes'.
- outStream isNil ifTrue:[
- self warn:'cannot create temporary file'.
- ^ self
- ].
-
- inStream := FileStream readonlyFileNamed:changeFileName.
- inStream isNil ifTrue:[^ nil].
-
- self withCursor:(Cursor write) do:[
- excla := inStream class chunkSeparator.
- 1 to:(changeChunks size) do:[:index |
- inStream position:(changePositions at:index).
- sawExcla := inStream peekFor:excla.
- chunk := inStream nextChunk.
-
- sawExcla ifTrue:[
- outStream nextPut:excla.
- outStream nextChunkPut:chunk.
- outStream cr.
- "a method-definition chunk - skip followups"
- done := false.
- [done] whileFalse:[
- chunk := inStream nextChunk.
- chunk isNil ifTrue:[
- done := true
- ] ifFalse:[
- outStream nextChunkPut:chunk.
- outStream cr.
- done := chunk isEmpty
- ]
- ].
- ] ifFalse:[
- outStream nextChunkPut:chunk.
- outStream cr
- ]
- ].
- outStream close.
- inStream close.
- dir := FileDirectory currentDirectory.
-"/ dir removeFile:changeFileName.
- dir renameFile:'changes' newName:'changes.bak'.
- dir renameFile:'n_changes' newName:changeFileName.
- anyChanges := false
+autoSelectOrEnd:changeNr
+ changeNr < changeChunks size ifTrue:[
+ self autoSelect:changeNr
+ ] ifFalse:[
+ self clearCodeView.
+ changeListView selection:changeChunks size.
+ self changeSelection:changeChunks size.
]
!
-setChangeList
- "extract type-information from changes and stuff into top selection
- view"
-
- changeListView contents:changeHeaderLines "changeChunks".
- self disableMenuEntries
-!
-
-readChangesFile
- "read the changes file, create a list of header-lines (changeChunks)
- and a list of chunk-positions (changePositions)"
-
- ^ self readChangesFileInBackground:false
-!
-
readChangesFileInBackground:inBackground
"read the changes file, create a list of header-lines (changeChunks)
and a list of chunk-positions (changePositions)"
@@ -461,125 +326,180 @@
aStream isNil ifTrue:[^ nil].
self withCursor:(Cursor read) do:[
- "
- this is a time consuming operation (especially, if reading an
- NFS-mounted directory; therefore lower my priority ...
- "
- inBackground ifTrue:[
- myProcess := Processor activeProcess.
- myPriority := myProcess priority.
- myProcess priority:(Processor userBackgroundPriority).
- ].
- [
- changeChunks := OrderedCollection new.
- changeHeaderLines := OrderedCollection new.
- changePositions := OrderedCollection new.
- excla := aStream class chunkSeparator.
+ "
+ this is a time consuming operation (especially, if reading an
+ NFS-mounted directory; therefore lower my priority ...
+ "
+ inBackground ifTrue:[
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+ ].
+ [
+ changeChunks := OrderedCollection new.
+ changeHeaderLines := OrderedCollection new.
+ changePositions := OrderedCollection new.
+ excla := aStream class chunkSeparator.
- [aStream atEnd] whileFalse:[
- "
- get a chunk (separated by excla)
- "
- aStream skipSeparators.
- chunkPos := aStream position.
- sawExcla := aStream peekFor:excla.
- chunkText := aStream nextChunk.
- chunkText notNil ifTrue:[
- "
- only first line is saved in changeChunks ...
- "
- index := chunkText indexOf:(Character cr).
- (index ~~ 0) ifTrue:[
- chunkText := chunkText copyTo:(index - 1).
+ [aStream atEnd] whileFalse:[
+ "
+ get a chunk (separated by excla)
+ "
+ aStream skipSeparators.
+ chunkPos := aStream position.
+ sawExcla := aStream peekFor:excla.
+ chunkText := aStream nextChunk.
+ chunkText notNil ifTrue:[
+ "
+ only first line is saved in changeChunks ...
+ "
+ index := chunkText indexOf:(Character cr).
+ (index ~~ 0) ifTrue:[
+ chunkText := chunkText copyTo:(index - 1).
+
+ "take care for comment changes - must still be a
+ valid expression for classNameOfChange: to work"
+
+ (chunkText endsWith:'comment:''') ifTrue:[
+ chunkText := chunkText , '...'''
+ ]
- "take care for comment changes - must still be a
- valid expression for classNameOfChange: to work"
+ ].
+
+ changeChunks add:chunkText.
+ changePositions add:chunkPos.
- (chunkText endsWith:'comment:''') ifTrue:[
- chunkText := chunkText , '...'''
- ]
-
- ].
-
- changeChunks add:chunkText.
- changePositions add:chunkPos.
+ sawExcla ifFalse:[
+ (chunkText startsWith:'''---- snap') ifFalse:[
+ headerLine := chunkText , ' (doIt)'
+ ] ifTrue:[
+ headerLine := chunkText
+ ].
+ changeHeaderLines add:headerLine.
+ ] ifTrue:[
+ "
+ method definitions actually consist of
+ two (or more) chunks; skip next chunk(s)
+ up to an empty one.
+ The system only writes one chunk,
+ and we cannot handle more in this ChangesBrowser ....
+ "
+ cls := nil.
+ p := Parser parseExpression:chunkText.
- sawExcla ifFalse:[
- (chunkText startsWith:'''---- snap') ifFalse:[
- headerLine := chunkText , ' (doIt)'
- ] ifTrue:[
- headerLine := chunkText
- ].
- changeHeaderLines add:headerLine.
- ] ifTrue:[
- "
- method definitions actually consist of
- two (or more) chunks; skip next chunk(s)
- up to an empty one.
- The system only writes one chunk,
- and we cannot handle more in this ChangesBrowser ....
- "
- cls := nil.
- p := Parser parseExpression:chunkText.
+ (p notNil and:[p ~~ #Error]) ifTrue:[
+ sel := p selector.
+ (sel == #methodsFor:) ifTrue:[
+ p receiver isUnaryMessage ifTrue:[
+ cls := p receiver receiver name.
+ cls := cls , 'class'
+ ] ifFalse:[
+ cls := p receiver name
+ ].
+ category := (p args at:1) evaluate.
+ ]
+ ].
+ done := false.
+ first := true.
+ [done] whileFalse:[
+ text := aStream nextChunk.
+ text isNil ifTrue:[
+ done := true
+ ] ifFalse:[
+ done := text isEmpty
+ ].
+ done ifFalse:[
+ first ifFalse:[
+ Transcript showCr:'only one method per ''methodsFor:'' handled'.
+ ] ifTrue:[
+ first := false.
+ "
+ try to find the selector
+ "
+ sel := nil.
+ cls notNil ifTrue:[
+ p := Parser
+ parseMethodSpecification:text
+ in:nil
+ ignoreErrors:true
+ ignoreWarnings:true.
+ (p notNil and:[p ~~ #Error]) ifTrue:[
+ sel := p selector.
+ ]
+ ].
+ sel isNil ifTrue:[
+ changeHeaderLines add:chunkText , ' (change)'.
+ ] ifFalse:[
+ changeHeaderLines add:cls , ' ' , sel , ' ' , '(change category: ''' , category , ''')'.
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ changeClassNames := OrderedCollection new grow:(changeChunks size).
+ aStream close.
+ anyChanges := false
+ ] valueNowOrOnUnwindDo:[
+ inBackground ifTrue:[myProcess priority:myPriority].
+ ].
+ ]
+!
- (p notNil and:[p ~~ #Error]) ifTrue:[
- sel := p selector.
- (sel == #methodsFor:) ifTrue:[
- p receiver isUnaryMessage ifTrue:[
- cls := p receiver receiver name.
- cls := cls , 'class'
- ] ifFalse:[
- cls := p receiver name
- ].
- category := (p args at:1) evaluate.
- ]
- ].
- done := false.
- first := true.
- [done] whileFalse:[
- text := aStream nextChunk.
- text isNil ifTrue:[
- done := true
- ] ifFalse:[
- done := text isEmpty
- ].
- done ifFalse:[
- first ifFalse:[
- Transcript showCr:'only one method per ''methodsFor:'' handled'.
- ] ifTrue:[
- first := false.
- "
- try to find the selector
- "
- sel := nil.
- cls notNil ifTrue:[
- p := Parser
- parseMethodSpecification:text
- in:nil
- ignoreErrors:true
- ignoreWarnings:true.
- (p notNil and:[p ~~ #Error]) ifTrue:[
- sel := p selector.
- ]
- ].
- sel isNil ifTrue:[
- changeHeaderLines add:chunkText , ' (change)'.
- ] ifFalse:[
- changeHeaderLines add:cls , ' ' , sel , ' ' , '(change category: ''' , category , ''')'.
- ]
- ]
- ]
- ]
- ]
- ]
- ].
- changeClassNames := OrderedCollection new grow:(changeChunks size).
- aStream close.
- anyChanges := false
- ] valueNowOrOnUnwindDo:[
- inBackground ifTrue:[myProcess priority:myPriority].
- ].
- ]
+queryCloseText
+ "made this a method for easy redefinition in subclasses"
+
+ ^ 'Quit without updating changeFile ?'
+!
+
+applyChange:changeNr
+ "fileIn a change"
+
+ |aStream upd sig nm cls|
+
+ aStream := self streamForChange:changeNr.
+ aStream isNil ifTrue:[^ self].
+
+ nm := self classNameOfChange:changeNr.
+ nm notNil ifTrue:[
+ cls := Smalltalk at:(nm asSymbol) ifAbsent:[].
+ cls notNil ifTrue:[
+ cls isLoaded ifFalse:[
+ cls autoload
+ ]
+ ]
+ ].
+
+ upd := Class updateChanges:false.
+
+ changeNrProcessed := changeNr.
+ [
+ (skipSignal notNil) ifTrue:[
+ sig := skipSignal
+ ] ifFalse:[
+ sig := Object abortSignal
+ ].
+ sig catch:[
+ aStream fileInNextChunkNotifying:self
+ ].
+ changeNrProcessed := nil.
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd.
+ aStream close
+ ].
+!
+
+changeFileName:aFileName
+ changeFileName := aFileName
+!
+
+setChangeList
+ "extract type-information from changes and stuff into top selection
+ view"
+
+ changeListView contents:changeHeaderLines "changeChunks".
+ self disableMenuEntries
!
silentDeleteChange:changeNr
@@ -592,13 +512,133 @@
changeHeaderLines removeIndex:changeNr
!
+writeBackChanges
+ "write back the changes file"
+
+ |inStream outStream chunk sawExcla excla done dir|
+
+ outStream := FileStream newFileNamed:'n_changes'.
+ outStream isNil ifTrue:[
+ self warn:'cannot create temporary file'.
+ ^ self
+ ].
+
+ inStream := FileStream readonlyFileNamed:changeFileName.
+ inStream isNil ifTrue:[^ nil].
+
+ self withCursor:(Cursor write) do:[
+ excla := inStream class chunkSeparator.
+ 1 to:(changeChunks size) do:[:index |
+ inStream position:(changePositions at:index).
+ sawExcla := inStream peekFor:excla.
+ chunk := inStream nextChunk.
+
+ sawExcla ifTrue:[
+ outStream nextPut:excla.
+ outStream nextChunkPut:chunk.
+ outStream cr.
+ "a method-definition chunk - skip followups"
+ done := false.
+ [done] whileFalse:[
+ chunk := inStream nextChunk.
+ chunk isNil ifTrue:[
+ done := true
+ ] ifFalse:[
+ outStream nextChunkPut:chunk.
+ outStream cr.
+ done := chunk isEmpty
+ ]
+ ].
+ ] ifFalse:[
+ outStream nextChunkPut:chunk.
+ outStream cr
+ ]
+ ].
+ outStream close.
+ inStream close.
+ dir := FileDirectory currentDirectory.
+"/ dir removeFile:changeFileName.
+ dir renameFile:'changes' newName:'changes.bak'.
+ dir renameFile:'n_changes' newName:changeFileName.
+ anyChanges := false
+ ]
+!
deleteChange:changeNr
"delete a change"
changeListView deselect.
self silentDeleteChange:changeNr.
- changeListView setContents:changeChunks
+ self setChangeList "/changeListView setContents:changeChunks
+
+!
+
+classNameOfChange:changeNr
+ "return the classname of a change (for xxx class - changes xxx is returned)
+ - since parsing ascii methods is slow, keep result cached in
+ changeClassNames for the next query"
+
+ |chunk aParseTree recTree sel name arg1Tree|
+
+ changeNr notNil ifTrue:[
+ "
+ first look, if not already known
+ "
+ name := changeClassNames at:changeNr.
+ name notNil ifTrue:[^ name].
+
+ "
+ get the chunk
+ "
+ chunk := changeChunks at:changeNr.
+ chunk notNil ifTrue:[
+ "
+ use parser to construct a parseTree
+ "
+ aParseTree := Parser parseExpression:chunk.
+ (aParseTree notNil and:[aParseTree isMessage]) ifTrue:[
+ "
+ ask parser for selector
+ "
+ sel := aParseTree selector.
+ "
+ is it a method-change, methodRemove or comment-change ?
+ "
+ (#(methodsFor: privateMethodsFor: publicMethodsFor:
+ removeSelector: comment:) includes:sel) ifTrue:[
+ "
+ yes, the className is the receiver
+ "
+ recTree := aParseTree receiver.
+ (recTree notNil and:[recTree ~~ #Error]) ifTrue:[
+ recTree isUnaryMessage ifTrue:[
+ (recTree selector ~~ #class) ifTrue:[^ nil].
+ "id class methodsFor:..."
+ recTree := recTree receiver
+ ].
+ recTree isPrimary ifTrue:[
+ name := recTree name.
+ changeClassNames at:changeNr put:name.
+ ^ name
+ ]
+ ]
+ ] ifFalse:[
+ "
+ is it a change in a class-description ?
+ "
+ ('subclass:*' match:sel) ifTrue:[
+ arg1Tree := aParseTree arg1.
+ (arg1Tree notNil and:[arg1Tree isConstant]) ifTrue:[
+ name := arg1Tree value asString.
+ changeClassNames at:changeNr put:name.
+ ^ name
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ nil
!
deleteChangesFrom:start to:stop
@@ -606,58 +646,17 @@
changeListView deselect.
stop to:start by:-1 do:[:changeNr |
- self silentDeleteChange:changeNr
+ self silentDeleteChange:changeNr
].
- changeListView setContents:changeChunks
-!
-
-deleteChangesFor:aClassName from:start to:stop
- "delete changes for a given class in a range"
+ self setChangeList "/changeListView setContents:changeChunks
- |thisClassName index|
-
- index := stop.
- [index >= start] whileTrue:[
- thisClassName := self classNameOfChange:index.
- thisClassName = aClassName ifTrue:[
- self silentDeleteChange:index
- ].
- index := index - 1
- ]
!
-applyChange:changeNr
- "filein a change"
-
- |aStream chunk sawExcla upd rslt|
-
- aStream := self streamForChange:changeNr.
- aStream isNil ifTrue:[^ self].
- sawExcla := aStream peekFor:(aStream class chunkSeparator).
- chunk := aStream nextChunk.
- upd := Class updateChanges:false.
-
- codeView abortAction:[Class updateChanges:upd.
- codeView abortAction:nil.
- aStream close.
- ^self].
+readChangesFile
+ "read the changes file, create a list of header-lines (changeChunks)
+ and a list of chunk-positions (changePositions)"
- changeNrProcessed := changeNr.
- [
- Object abortSignal catch:[
- |rslt|
-
- rslt := Compiler evaluate:chunk notifying:self.
- sawExcla ifTrue:[
- rslt fileInFrom:aStream notifying:self
- ]
- ].
- changeNrProcessed := nil.
- codeView abortAction:nil
- ] valueNowOrOnUnwindDo:[
- Class updateChanges:upd.
- aStream close
- ].
+ ^ self readChangesFileInBackground:false
!
compareChange:changeNr
@@ -672,50 +671,50 @@
sawExcla := aStream peekFor:(aStream class chunkSeparator).
chunk := aStream nextChunk.
sawExcla ifFalse:[
- outcome := 'not comparable ...'
+ outcome := 'not comparable ...'
] ifTrue:[
- parseTree := Parser parseExpression:chunk.
- (parseTree notNil and:[parseTree isMessage]) ifTrue:[
- (parseTree selector == #methodsFor:) ifTrue:[
- thisClass := (parseTree receiver evaluate).
- thisClass isBehavior ifTrue:[
- showDiff := false.
- cat := parseTree arg1 evaluate.
- newSource := aStream nextChunk.
- parser := Parser parseMethod:newSource in:thisClass.
- (parser notNil and:[parser ~~ #Error]) ifTrue:[
- sel := parser selector.
- oldMethod := thisClass compiledMethodAt:sel.
- oldMethod notNil ifTrue:[
- (oldMethod category = cat) ifFalse:[
- Transcript showCr:'category changed.'.
- ].
- oldSource := oldMethod source.
- (oldSource = newSource) ifTrue:[
- outcome := 'same source'
- ] ifFalse:[
- outcome := 'source changed.'.
- showDiff := true
- ]
- ] ifFalse:[
- outcome := 'method does not exist.'
- ]
- ] ifFalse:[
- outcome := 'change unparsable.'
- ].
- (showDiff and:[oldSource notNil and:[newSource notNil]]) ifTrue:[
- d := DiffTextView openOn:oldSource and:newSource.
- d label:'differences (current left; change right)'.
- ]
- ] ifFalse:[
- outcome := 'class does not exist.'
- ]
- ] ifFalse:[
- outcome := 'not comparable.'
- ]
- ] ifFalse:[
- outcome := 'not comparable.'
- ]
+ parseTree := Parser parseExpression:chunk.
+ (parseTree notNil and:[parseTree isMessage]) ifTrue:[
+ (parseTree selector == #methodsFor:) ifTrue:[
+ thisClass := (parseTree receiver evaluate).
+ thisClass isBehavior ifTrue:[
+ showDiff := false.
+ cat := parseTree arg1 evaluate.
+ newSource := aStream nextChunk.
+ parser := Parser parseMethod:newSource in:thisClass.
+ (parser notNil and:[parser ~~ #Error]) ifTrue:[
+ sel := parser selector.
+ oldMethod := thisClass compiledMethodAt:sel.
+ oldMethod notNil ifTrue:[
+ (oldMethod category = cat) ifFalse:[
+ Transcript showCr:'category changed.'.
+ ].
+ oldSource := oldMethod source.
+ (oldSource = newSource) ifTrue:[
+ outcome := 'same source'
+ ] ifFalse:[
+ outcome := 'source changed.'.
+ showDiff := true
+ ]
+ ] ifFalse:[
+ outcome := 'method does not exist.'
+ ]
+ ] ifFalse:[
+ outcome := 'change unparsable.'
+ ].
+ (showDiff and:[oldSource notNil and:[newSource notNil]]) ifTrue:[
+ d := DiffTextView openOn:oldSource and:newSource.
+ d label:'differences (current left; change right)'.
+ ]
+ ] ifFalse:[
+ outcome := 'class does not exist.'
+ ]
+ ] ifFalse:[
+ outcome := 'not comparable.'
+ ]
+ ] ifFalse:[
+ outcome := 'not comparable.'
+ ]
].
Transcript showCr:outcome.
aStream close.
@@ -728,38 +727,38 @@
outStream := FileStream oldFileNamed:fileName.
outStream isNil ifTrue:[
- outStream isNil ifTrue:[
- outStream := FileStream newFileNamed:fileName.
- outStream isNil ifTrue:[
- self warn:'cannot update file ''', fileName , ''''.
- ^ false
- ]
- ]
+ outStream isNil ifTrue:[
+ outStream := FileStream newFileNamed:fileName.
+ outStream isNil ifTrue:[
+ self warn:'cannot update file ''%1''' with:fileName.
+ ^ false
+ ]
+ ]
].
outStream setToEnd.
aStream := self streamForChange:changeNr.
aStream isNil ifTrue:[
- self warn:'oops cannot read change'.
- ^ false
+ self warn:'oops cannot read change'.
+ ^ false
].
separator := aStream class chunkSeparator.
sawExcla := aStream peekFor:separator.
sawExcla ifTrue:[
- outStream nextPut:separator
+ outStream nextPut:separator
].
chunk := aStream nextChunk.
outStream nextChunkPut:chunk.
outStream cr.
sawExcla ifTrue:[
- chunk := aStream nextChunk.
- outStream nextChunkPut:chunk.
- outStream space
+ chunk := aStream nextChunk.
+ outStream nextChunkPut:chunk.
+ outStream space
].
sawExcla ifTrue:[
- outStream nextPut:separator
+ outStream nextPut:separator
].
outStream cr.
aStream close.
@@ -777,48 +776,26 @@
"rewrite the source file where change changeNr lies"
self notify:'this is not yet implemented'
-! !
-
-!ChangesBrowser methodsFor:'error handling'!
-
-correctableError:aString position:relPos to:relEndPos
- "compiler notifys us of an error - this should really not happen since
- changes ought to be correct (did someone edit the changes file ??).
- Show the bad change in the codeView and let codeView hilight the error;
- no corrections allowed here therefore return false"
-
- (changeNrProcessed ~~ changeNrShown) ifTrue:[
- self changeSelection:changeNrProcessed
- ].
- codeView error:aString position:relPos to:relEndPos.
- ^ false
!
-error:aString position:relPos to:relEndPos
- "compiler notifys us of an error - this should really not happen since
- changes ought to be correct (did someone edit the changes file ??).
- Show the bad change in the codeView and let codeView hilight the error"
+silentDeleteChangesFor:aClassName from:start to:stop
+ "delete changes for a given class in a range"
+
+ |thisClassName index|
- (changeNrProcessed ~~ changeNrShown) ifTrue:[
- self changeSelection:changeNrProcessed
- ].
- ^ codeView error:aString position:relPos to:relEndPos
-!
+ index := stop.
+ [index >= start] whileTrue:[
+ thisClassName := self classNameOfChange:index.
+ thisClassName = aClassName ifTrue:[
+ self silentDeleteChange:index
+ ].
+ index := index - 1
+ ]
-warning:aString position:relPos to:relEndPos
- "compiler notifys us of a warning - ignore it"
-
- ^ self
! !
!ChangesBrowser methodsFor:'user interaction'!
-noChangesAllowed
- "show a warning that changes cannot be changed"
-
- self warn:(resources at:'changes are not allowed to be changed')
-!
-
changeSelection:lineNr
"show a change in the codeView"
@@ -829,7 +806,7 @@
sawExcla := aStream peekFor:(aStream class chunkSeparator).
chunk := aStream nextChunk.
sawExcla ifTrue:[
- chunk := aStream nextChunk
+ chunk := aStream nextChunk
].
aStream close.
codeView contents:chunk.
@@ -838,6 +815,12 @@
self enableMenuEntries
!
+noChangesAllowed
+ "show a warning that changes cannot be changed"
+
+ self warn:'changes are not allowed to be changed'
+!
+
doSaveClass
"user wants changes for some class from current to end to be appended to a file"
@@ -850,6 +833,21 @@
self doSaveClassFrom:1
!
+doApply
+ "user wants a change to be applied"
+
+ |changeNr|
+
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ self withCursor:(Cursor execute) do:[
+ skipSignal := nil.
+ self applyChange:changeNr.
+ self autoSelect:(changeNr + 1)
+ ]
+ ]
+!
+
doSaveClassRest
"user wants changes for some class from current to end to be appended to a file"
@@ -857,7 +855,7 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self doSaveClassFrom:changeNr
+ self doSaveClassFrom:changeNr
]
!
@@ -868,27 +866,43 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- fileBox := FileSelectionBox new.
- fileBox title:'append change to:'.
- fileBox okText:'append'.
- fileBox abortText:'cancel'.
- fileBox action:[:fileName |
- |thisClassName|
- self withCursor:(Cursor write) do:[
- startNr to:(changeChunks size) do:[:changeNr |
- thisClassName := self classNameOfChange:changeNr.
- thisClassName = aClassName ifTrue:[
- changeListView selection:changeNr.
- (self appendChange:changeNr toFile:fileName) ifFalse:[
- ^ self
- ]
- ]
- ]
- ]
- ].
+ fileBox := FileSelectionBox new.
+ fileBox title:'append change to:'.
+ fileBox okText:'append'.
+ fileBox abortText:'cancel'.
+ fileBox action:[:fileName |
+ |thisClassName|
+ self withCursor:(Cursor write) do:[
+ startNr to:(changeChunks size) do:[:changeNr |
+ thisClassName := self classNameOfChange:changeNr.
+ thisClassName = aClassName ifTrue:[
+ changeListView selection:changeNr.
+ (self appendChange:changeNr toFile:fileName) ifFalse:[
+ ^ self
+ ]
+ ]
+ ]
+ ]
+ ].
- fileBox pattern:'*.chg'.
- fileBox showAtPointer
+ fileBox pattern:'*.chg'.
+ fileBox showAtPointer
+ ]
+!
+
+doBrowse
+ "user wants a browser on the class of a change"
+
+ |changeNr className cls|
+
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ className := self classNameOfChange:changeNr.
+ className notNil ifTrue:[
+ (cls := Smalltalk classNamed:className) notNil ifTrue:[
+ SystemBrowser browseClass:cls
+ ]
+ ]
]
!
@@ -899,10 +913,10 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- classNameToSave := self classNameOfChange:changeNr.
- classNameToSave notNil ifTrue:[
- self saveClass:classNameToSave from:startNr
- ]
+ classNameToSave := self classNameOfChange:changeNr.
+ classNameToSave notNil ifTrue:[
+ self saveClass:classNameToSave from:startNr
+ ]
]
!
@@ -913,23 +927,23 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- fileBox := FileSelectionBox new.
- fileBox title:'append change to:'.
- fileBox okText:'append'.
- fileBox abortText:'cancel'.
- fileBox action:[:fileName |
- self withCursor:(Cursor write) do:[
- changeNr to:(changeChunks size) do:[:changeNr |
- changeListView selection:changeNr.
- (self appendChange:changeNr toFile:fileName) ifFalse:[
- ^ self
- ]
- ]
- ]
- ].
+ fileBox := FileSelectionBox new.
+ fileBox title:'append change to:'.
+ fileBox okText:'append'.
+ fileBox abortText:'cancel'.
+ fileBox action:[:fileName |
+ self withCursor:(Cursor write) do:[
+ changeNr to:(changeChunks size) do:[:changeNr |
+ changeListView selection:changeNr.
+ (self appendChange:changeNr toFile:fileName) ifFalse:[
+ ^ self
+ ]
+ ]
+ ]
+ ].
- fileBox pattern:'*.chg'.
- fileBox showAtPointer
+ fileBox pattern:'*.chg'.
+ fileBox showAtPointer
]
!
@@ -940,19 +954,19 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- fileBox := FileSelectionBox new.
- fileBox title:'append change to:'.
- fileBox okText:'append'.
- fileBox abortText:'cancel'.
- fileBox action:[:fileName |
- self withCursor:(Cursor write) do:[
- self appendChange:changeNr toFile:fileName.
- ].
- self autoSelect:(changeNr + 1)
- ].
+ fileBox := FileSelectionBox new.
+ fileBox title:'append change to:'.
+ fileBox okText:'append'.
+ fileBox abortText:'cancel'.
+ fileBox action:[:fileName |
+ self withCursor:(Cursor write) do:[
+ self appendChange:changeNr toFile:fileName.
+ ].
+ self autoSelect:(changeNr + 1)
+ ].
- fileBox pattern:'*.chg'.
- fileBox showAtPointer
+ fileBox pattern:'*.chg'.
+ fileBox showAtPointer
]
!
@@ -967,12 +981,12 @@
yesNoBox okText:(resources at:'continue').
yesNoBox noText:(resources at:'abort').
yesNoBox okAction:[
- changeNr := changeListView selection.
- changeNr notNil ifTrue:[
- self makeChangePermanent:changeNr.
- self autoSelect:(changeNr + 1)
- ]
- ].
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ self makeChangePermanent:changeNr.
+ self autoSelect:(changeNr + 1)
+ ]
+ ].
yesNoBox showAtPointer
!
@@ -984,51 +998,8 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self makeChangeAPatch:changeNr.
- self autoSelect:(changeNr + 1)
- ]
-!
-
-doApply
- "user wants a change to be applied"
-
- |changeNr|
-
- changeNr := changeListView selection.
- changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- self applyChange:changeNr.
- self autoSelect:(changeNr + 1)
- ]
- ]
-!
-
-doApplyAll
- "user wants all changes to be applied"
-
- self withCursor:(Cursor execute) do:[
- self clearCodeView.
- 1 to:(changePositions size) do:[:changeNr |
- changeListView selection:changeNr.
- self applyChange:changeNr
- ]
- ]
-!
-
-doApplyRest
- "user wants all changes from changeNr to be applied"
-
- |changeNr|
-
- changeNr := changeListView selection.
- changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- self clearCodeView.
- changeNr to:(changePositions size) do:[:changeNr |
- changeListView selection:changeNr.
- self applyChange:changeNr
- ]
- ]
+ self makeChangeAPatch:changeNr.
+ self autoSelect:(changeNr + 1)
]
!
@@ -1039,8 +1010,45 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self deleteChange:changeNr.
- self autoSelect:changeNr
+ self deleteChange:changeNr.
+ self autoSelectOrEnd:changeNr
+ ]
+!
+
+doApplyRest
+ "user wants all changes from changeNr to be applied"
+
+ |changeNr|
+
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ self withCursor:(Cursor execute) do:[
+ self clearCodeView.
+ skipSignal isNil ifTrue:[skipSignal := Signal new].
+"/ Object abortSignal catch:[
+ changeNr to:(changePositions size) do:[:changeNr |
+ changeListView selection:changeNr.
+ self applyChange:changeNr
+"/ ]
+ ].
+"/ skipSignal := nil
+ ]
+ ]
+!
+
+doApplyAll
+ "user wants all changes to be applied"
+
+ self withCursor:(Cursor execute) do:[
+ self clearCodeView.
+ skipSignal isNil ifTrue:[skipSignal := Signal new].
+"/ Object abortSignal catch:[
+ 1 to:(changePositions size) do:[:changeNr |
+ changeListView selection:changeNr.
+ self applyChange:changeNr
+"/ ]
+ ].
+"/ skipSignal := nil
]
!
@@ -1051,17 +1059,31 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- classNameToDelete := self classNameOfChange:changeNr.
- classNameToDelete notNil ifTrue:[
- changeListView selection:nil.
- self deleteChangesFor:classNameToDelete
- from:changeNr
- to:(changeChunks size).
- changeListView setContents:changeChunks.
- self autoSelect:changeNr
- ]
- ]
+ self withCursor:(Cursor execute) do:[
+ classNameToDelete := self classNameOfChange:changeNr.
+ classNameToDelete notNil ifTrue:[
+ changeListView selection:nil.
+ self silentDeleteChangesFor:classNameToDelete
+ from:changeNr
+ to:(changeChunks size).
+ self setChangeList. "/changeListView setContents:changeChunks.
+ self autoSelectOrEnd:changeNr
+ ]
+ ]
+ ]
+!
+
+doWriteBack
+ "write back the list onto the changes file"
+
+ anyChanges ifTrue:[
+ self writeBackChanges.
+ realized ifTrue:[
+ self readChangesFileInBackground:false.
+ realized ifTrue:[
+ self setChangeList
+ ]
+ ]
]
!
@@ -1072,8 +1094,152 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self deleteChangesFrom:changeNr to:(changeChunks size).
- self clearCodeView
+ self deleteChangesFrom:changeNr to:(changeChunks size).
+ self clearCodeView.
+ self autoSelectOrEnd:changeNr-1
+ ]
+!
+
+doCompress
+ "compress the change-set; this replaces multiple method-changes by the last
+ (i.e. the most recent) change"
+
+ |classes types selectors thisClass thisSelector
+ aStream chunk changeNr sawExcla aParseTree codeChunk codeParser
+ searchIndex anyMore deleteSet index parseTreeChunk numChanges
+ excla snapshotProto str snapshotPrefix snapshotNameIndex fileName|
+
+ aStream := FileStream readonlyFileNamed:changeFileName.
+ aStream isNil ifTrue:[^ self].
+
+ "
+ get a prototype snapshot record (to be independent of
+ the actual format ..
+ "
+ str := WriteStream on:String new.
+ Class addChangeRecordForSnapshot:'foo' to:str.
+ snapshotProto := str contents.
+ snapshotPrefix := snapshotProto copyTo:10.
+ snapshotNameIndex := snapshotProto findString:'foo'.
+
+ self withCursor:(Cursor execute) do:[
+ numChanges := changePositions size.
+ classes := Array new:numChanges.
+ selectors := Array new:numChanges.
+ types := Array new:numChanges.
+
+ "starting at the end, get the change class and change selector;
+ collect all in classes / selectors"
+
+ changeNr := numChanges.
+ excla := aStream class chunkSeparator.
+
+ [changeNr >= 1] whileTrue:[
+ aStream position:(changePositions at:changeNr).
+ sawExcla := aStream peekFor:excla.
+ chunk := aStream nextChunk.
+ sawExcla ifTrue:[
+ "optimize a bit if multiple methods for same category arrive"
+ (chunk = parseTreeChunk) ifFalse:[
+ aParseTree := Parser parseExpression:chunk.
+ parseTreeChunk := chunk
+ ].
+ (aParseTree notNil
+ and:[(aParseTree ~~ #Error)
+ and:[aParseTree isMessage]]) ifTrue:[
+ (aParseTree selector == #methodsFor:) ifTrue:[
+ thisClass := (aParseTree receiver evaluate).
+ codeChunk := aStream nextChunk.
+ codeParser := Parser
+ parseMethodSpecification:codeChunk
+ in:thisClass
+ ignoreErrors:true
+ ignoreWarnings:true.
+ codeParser notNil ifTrue:[
+ selectors at:changeNr put:(codeParser selector).
+ classes at:changeNr put:thisClass.
+ types at:changeNr put:#methodsFor
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ aParseTree := Parser parseExpression:chunk.
+ parseTreeChunk := chunk.
+ (aParseTree notNil
+ and:[(aParseTree ~~ #Error)
+ and:[aParseTree isMessage]]) ifTrue:[
+ (aParseTree selector == #removeSelector:) ifTrue:[
+ selectors at:changeNr put:(aParseTree arg1 value ).
+ classes at:changeNr put:(aParseTree receiver evaluate).
+ types at:changeNr put:#removeSelector
+ ]
+ ] ifFalse:[
+ (chunk startsWith:snapshotPrefix) ifTrue:[
+ str := chunk readStream position:snapshotNameIndex.
+ fileName := str upTo:(Character space).
+ "
+ kludge to allow use of match-check below
+ "
+ selectors at:changeNr put:snapshotPrefix.
+ classes at:changeNr put:fileName.
+ ]
+ ]
+ ].
+ changeNr := changeNr - 1
+ ].
+ aStream close.
+
+ "for all changes, look for another class/selector occurence later
+ in the list and, if there is one, add change number to the delete set"
+
+ deleteSet := OrderedCollection new.
+ changeNr := 1.
+ [changeNr < changePositions size] whileTrue:[
+ thisClass := classes at:changeNr.
+ thisSelector := selectors at:changeNr.
+ searchIndex := changeNr.
+ anyMore := true.
+ [anyMore] whileTrue:[
+ searchIndex := classes indexOf:thisClass
+ startingAt:(searchIndex + 1).
+ (searchIndex ~~ 0) ifTrue:[
+ ((selectors at:searchIndex) == thisSelector) ifTrue:[
+ thisClass notNil ifTrue:[
+ deleteSet add:changeNr.
+ anyMore := false
+ ]
+ ]
+ ] ifFalse:[
+ anyMore := false
+ ]
+ ].
+ changeNr := changeNr + 1
+ ].
+
+ "finally delete what has been found"
+
+ (deleteSet size > 0) ifTrue:[
+ changeListView selection:nil.
+ index := deleteSet size.
+ [index > 0] whileTrue:[
+ self silentDeleteChange:(deleteSet at:index).
+ index := index - 1
+ ].
+ self setChangeList.
+ changeListView firstLineShown > changeChunks size ifTrue:[
+ changeListView makeLineVisible:changeChunks size
+ ].
+ self clearCodeView
+ ]
+ ]
+!
+
+doUpdate
+ "reread the changes-file"
+
+ self readChangesFileInBackground:true.
+ realized ifTrue:[
+ self setChangeList
]
!
@@ -1084,38 +1250,17 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- classNameToDelete := self classNameOfChange:changeNr.
- classNameToDelete notNil ifTrue:[
- changeListView selection:nil.
- self deleteChangesFor:classNameToDelete
- from:1
- to:(changeChunks size).
- changeListView contents:changeChunks.
- self autoSelect:changeNr
- ]
- ]
- ]
-!
-
-doWriteBack
- "write back the list onto the changes file"
-
- anyChanges ifTrue:[
- self writeBackChanges.
- realized ifTrue:[
- self readChangesFileInBackground:false.
- self setChangeList
- ]
- ]
-!
-
-doUpdate
- "reread the changes-file"
-
- self readChangesFileInBackground:true.
- realized ifTrue:[
- self setChangeList
+ self withCursor:(Cursor execute) do:[
+ classNameToDelete := self classNameOfChange:changeNr.
+ classNameToDelete notNil ifTrue:[
+ changeListView selection:nil.
+ self silentDeleteChangesFor:classNameToDelete
+ from:1
+ to:(changeChunks size).
+ self setChangeList. "/changeListView setContents:changeChunks.
+ self autoSelectOrEnd:changeNr
+ ]
+ ]
]
!
@@ -1127,122 +1272,97 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- self compareChange:changeNr
- ]
+ self withCursor:(Cursor execute) do:[
+ self compareChange:changeNr
+ ]
]
+! !
+
+!ChangesBrowser methodsFor:'error handling'!
+
+correctableError:aString position:relPos to:relEndPos
+ "compiler notifys us of an error - this should really not happen since
+ changes ought to be correct (did someone edit the changes file ??).
+ Show the bad change in the codeView and let codeView hilight the error;
+ no corrections allowed here therefore return false"
+
+ |action|
+
+ (changeNrProcessed ~~ changeNrShown) ifTrue:[
+ self changeSelection:changeNrProcessed
+ ].
+ (skipSignal notNil) ifTrue:[
+
+ codeView highlightingErrorPosition:relPos to:relEndPos do:[
+ |box|
+
+ "
+ start dialog - make certain cleanup is done
+ "
+ box := OptionBox title:aString numberOfOptions:3.
+ box buttonTitles:#('abort' 'skip' 'continue').
+ box actions:(Array with:[action := #abort]
+ with:[action := #skip]
+ with:[action := #continue]).
+ box showAtPointer
+ ].
+
+ action == #abort ifTrue:[
+ Object abortSignal raise.
+ ^ false
+ ].
+ action == #skip ifTrue:[
+ skipSignal raise.
+ ^ false
+ ].
+ ^ false
+ ].
+ codeView error:aString position:relPos to:relEndPos.
+ ^ false
!
-doCompress
- "compress the change-set; this replaces multiple method-changes by the last
- (i.e. the most recent) change"
+error:aString position:relPos to:relEndPos
+ "compiler notifys us of an error - this should really not happen since
+ changes ought to be correct (did someone edit the changes file ??).
+ Show the bad change in the codeView and let codeView hilight the error"
- |classes types selectors thisClass thisSelector
- aStream chunk changeNr sawExcla aParseTree codeChunk codeParser
- searchIndex anyMore deleteSet index parseTreeChunk numChanges
- excla|
-
- aStream := FileStream readonlyFileNamed:changeFileName.
- aStream isNil ifTrue:[^ self].
+ |action|
- self withCursor:(Cursor execute) do:[
- numChanges := changePositions size.
- classes := Array new:numChanges.
- selectors := Array new:numChanges.
- types := Array new:numChanges.
+ (changeNrProcessed ~~ changeNrShown) ifTrue:[
+ self changeSelection:changeNrProcessed
+ ].
+ (skipSignal notNil) ifTrue:[
- "starting at the end, get the change class and change selector;
- collect all in classes / selectors"
-
- changeNr := numChanges.
- excla := aStream class chunkSeparator.
+ codeView highlightingErrorPosition:relPos to:relEndPos do:[
+ |box|
- [changeNr >= 1] whileTrue:[
- aStream position:(changePositions at:changeNr).
- sawExcla := aStream peekFor:excla.
- chunk := aStream nextChunk.
- sawExcla ifTrue:[
- "optimize a bit if multiple methods for same category arrive"
- (chunk = parseTreeChunk) ifFalse:[
- aParseTree := Parser parseExpression:chunk.
- parseTreeChunk := chunk
- ].
- (aParseTree notNil
- and:[(aParseTree ~~ #Error)
- and:[aParseTree isMessage]]) ifTrue:[
- (aParseTree selector == #methodsFor:) ifTrue:[
- thisClass := (aParseTree receiver evaluate).
- codeChunk := aStream nextChunk.
- codeParser := Parser
- parseMethodSpecification:codeChunk
- in:thisClass
- ignoreErrors:true
- ignoreWarnings:true.
- codeParser notNil ifTrue:[
- selectors at:changeNr put:(codeParser selector).
- classes at:changeNr put:thisClass.
- types at:changeNr put:#methodsFor
- ]
- ]
- ]
- ] ifFalse:[
- aParseTree := Parser parseExpression:chunk.
- parseTreeChunk := chunk.
- (aParseTree notNil
- and:[(aParseTree ~~ #Error)
- and:[aParseTree isMessage]]) ifTrue:[
- (aParseTree selector == #removeSelector:) ifTrue:[
- selectors at:changeNr put:(aParseTree arg1 value ).
- classes at:changeNr put:(aParseTree receiver evaluate).
- types at:changeNr put:#removeSelector
- ]
- ]
- ].
- changeNr := changeNr - 1
- ].
- aStream close.
+ "
+ start dialog - make certain cleanup is done
+ "
+ box := OptionBox title:aString numberOfOptions:3.
+ box buttonTitles:#('abort' 'skip' 'continue').
+ box actions:(Array with:[action := #abort]
+ with:[action := #skip]
+ with:[action := #continue]).
+ box showAtPointer
+ ].
- "for all changes, look for another class/selector occurence and
- add change number to delete set if found"
+ action == #abort ifTrue:[
+ Object abortSignal raise.
+ ^ false
+ ].
+ action == #skip ifTrue:[
+ skipSignal raise.
+ ^ false
+ ].
+ ^ false
+ ].
+ ^ codeView error:aString position:relPos to:relEndPos
+!
- deleteSet := OrderedCollection new.
- changeNr := 1.
- [changeNr < changePositions size] whileTrue:[
- thisClass := classes at:changeNr.
- thisSelector := selectors at:changeNr.
- searchIndex := changeNr.
- anyMore := true.
- [anyMore] whileTrue:[
- searchIndex := classes indexOf:thisClass
- startingAt:(searchIndex + 1).
- (searchIndex ~~ 0) ifTrue:[
- ((selectors at:searchIndex) == thisSelector) ifTrue:[
- thisClass notNil ifTrue:[
- deleteSet add:changeNr.
- anyMore := false
- ]
- ]
- ] ifFalse:[
- anyMore := false
- ]
- ].
- changeNr := changeNr + 1
- ].
+warning:aString position:relPos to:relEndPos
+ "compiler notifys us of a warning - ignore it"
- "finally delete what has been found"
+ ^ self
+! !
- (deleteSet size > 0) ifTrue:[
- changeListView selection:nil.
- index := deleteSet size.
- [index > 0] whileTrue:[
- self silentDeleteChange:(deleteSet at:index).
- index := index - 1
- ].
- self setChangeList.
- changeListView firstLineShown > changeChunks size ifTrue:[
- changeListView makeLineVisible:changeChunks size
- ].
- self clearCodeView
- ]
- ]
-! !
--- a/ChangeSetBrowser.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ChangeSetBrowser.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +13,17 @@
"
ChangesBrowser subclass:#ChangeSetBrowser
- instanceVariableNames:'changeSet originalChangeSet'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'changeSet originalChangeSet'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
ChangeSetBrowser comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.2 1994-08-23 23:48:28 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.3 1994-10-10 03:15:18 claus Exp $
'!
!ChangeSetBrowser class methodsFor:'documentation'!
@@ -31,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.2 1994-08-23 23:48:28 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.3 1994-10-10 03:15:18 claus Exp $
"
!
@@ -59,7 +59,7 @@
openOn:aChangeSet
"create c changes browser on a change set"
- ^ ((self new label:'ChangeSet Browser') changeSet:aChangeSet) realize
+ ^ ((self new label:'ChangeSet Browser') changeSet:aChangeSet) open
! !
!ChangeSetBrowser methodsFor:'initialize / release'!
@@ -68,53 +68,53 @@
|labels|
labels := resources array:#(
- 'apply change'
- 'apply changes to end'
- 'apply all changes'
- '-'
- 'delete'
- 'delete to end'
- 'delete changes for this class to end'
- 'delete all changes for this class'
- '-'
- 'update'
- 'compress'
- 'compare with current version'
- '-'
- 'make change a patch'
- 'update sourcefile from change'
- '-'
- 'saveback changeSet').
+ 'apply change'
+ 'apply changes to end'
+ 'apply all changes'
+ '-'
+ 'delete'
+ 'delete to end'
+ 'delete changes for this class to end'
+ 'delete all changes for this class'
+ '-'
+ 'update'
+ 'compress'
+ 'compare with current version'
+ '-'
+ 'make change a patch'
+ 'update sourcefile from change'
+ '-'
+ 'saveback changeSet').
changeListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(
- doApply
- doApplyRest
- doApplyAll
- nil
- doDelete
- doDeleteRest
- doDeleteClassRest
- doDeleteClassAll
- nil
- doUpdate
- doCompress
- doCompare
- nil
- doMakePatch
- doMakePermanent
- nil
- doSaveBack)
- receiver:self
- for:changeListView)
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ doApply
+ doApplyRest
+ doApplyAll
+ nil
+ doDelete
+ doDeleteRest
+ doDeleteClassRest
+ doDeleteClassAll
+ nil
+ doUpdate
+ doCompress
+ doCompare
+ nil
+ doMakePatch
+ doMakePermanent
+ nil
+ doSaveBack)
+ receiver:self
+ for:changeListView)
! !
!ChangeSetBrowser methodsFor:'private'!
queryCloseText
- ^ 'Quit without updating changeSet ?'
+ ^ 'Quit without updating changeSet ?'
!
streamForChange:changeNr
@@ -131,23 +131,25 @@
originalChangeSet := aChangeSet.
changeSet := OrderedCollection new.
originalChangeSet do:[:aChange |
- changeSet add:aChange
+ changeSet add:aChange
].
!
-readChangesFile
+readChangesFileInBackground:dummy
"read the changeSet, create a list of header-lines"
changeSet size == 0 ifTrue:[^ nil].
self withCursor:(Cursor read) do:[
- changeChunks := VariableArray new.
+ changeChunks := OrderedCollection new.
+ changeHeaderLines := OrderedCollection new.
- changeSet do:[:aChange |
- changeChunks add:(aChange printString)
- ].
- changeClassNames := VariableArray new:(changeChunks size).
- anyChanges := false
+ changeSet do:[:aChange |
+ changeChunks add:(aChange printString).
+ changeHeaderLines add:(aChange printString)
+ ].
+ changeClassNames := OrderedCollection new:(changeChunks size).
+ anyChanges := false
]
!
@@ -155,10 +157,10 @@
"save back the change set"
[originalChangeSet isEmpty] whileFalse:[
- originalChangeSet removeLast
+ originalChangeSet removeLast
].
changeSet do:[:aChange |
- originalChangeSet add:aChange
+ originalChangeSet add:aChange
]
!
@@ -175,7 +177,7 @@
doSaveBack
anyChanges ifTrue:[
- self saveBackChanges.
- self doUpdate
+ self saveBackChanges.
+ self doUpdate
]
! !
--- a/ChangesBrowser.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ChangesBrowser.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,8 +1,6 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -12,22 +10,22 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.3 on 26-sep-1994 at 1:19:22 pm'!
+
StandardSystemView subclass:#ChangesBrowser
- instanceVariableNames:'changeListView codeView changeFileName
- changeChunks changePositions
- changeClassNames changeHeaderLines
- anyChanges changeNrShown changeNrProcessed
- fileBox'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'changeListView codeView changeFileName changeChunks
+ changePositions changeClassNames changeHeaderLines anyChanges
+ changeNrShown changeNrProcessed fileBox skipSignal'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
ChangesBrowser comment:'
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.15 1994-08-22 18:06:51 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.16 1994-10-10 03:15:12 claus Exp $
'!
!ChangesBrowser class methodsFor:'documentation'!
@@ -35,7 +33,7 @@
copyright
"
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -48,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.15 1994-08-22 18:06:51 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.16 1994-10-10 03:15:12 claus Exp $
"
!
@@ -61,6 +59,21 @@
"
! !
+!ChangesBrowser class methodsFor:'instance creation'!
+
+new
+ "create a new changes browser"
+
+ ^ super label:'Changes Browser'
+ icon:(Form fromFile:'CBrowser.xbm' resolution:100)
+!
+
+openOn:aFileName
+ "create c changes browser on a change file"
+
+ ^ ((self new label:'Changes Browser:', aFileName) changeFileName:aFileName) open
+! !
+
!ChangesBrowser class methodsFor:'behavior'!
autoSelectNext
@@ -70,23 +83,67 @@
^ true
! !
-!ChangesBrowser class methodsFor:'instance creation'!
+!ChangesBrowser methodsFor:'initialize / release'!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#(
+ 'apply change'
+ 'apply changes to end'
+ 'apply all changes'
+ '-'
+ 'delete'
+ 'delete to end'
+ 'delete changes for this class to end'
+ 'delete all changes for this class'
+ '-'
+ 'update'
+ 'compress'
+ 'compare with current version'
+ 'browse class'
+ '-'
+ 'make change a patch'
+"/ 'update sourcefile from change'
+"/ '-'
+ 'save change in file ...'
+ 'save changes to end in file ...'
+ 'save changes for this class to end in file ...'
+ 'save all changes for this class in file ...'
+ '-'
+ 'writeback changeFile').
-new
- "create a new changes browser"
-
- ^ super label:'Changes Browser'
- icon:(Form fromFile:'CBrowser.xbm' resolution:100)
+ changeListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ doApply
+ doApplyRest
+ doApplyAll
+ nil
+ doDelete
+ doDeleteRest
+ doDeleteClassRest
+ doDeleteClassAll
+ nil
+ doUpdate
+ doCompress
+ doCompare
+ doBrowse
+ nil
+ doMakePatch
+"/ doMakePermanent
+"/ nil
+ doSave
+ doSaveRest
+ doSaveClassRest
+ doSaveClassAll
+ nil
+ doWriteBack)
+ receiver:self
+ for:changeListView)
!
-openOn:aFileName
- "create c changes browser on a change file"
-
- ^ ((self new label:'Changes Browser:', aFileName) changeFileName:aFileName) open
-! !
-
-!ChangesBrowser methodsFor:'initialize / release'!
-
initialize
|frame v|
@@ -95,9 +152,9 @@
changeFileName := 'changes'.
frame := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- borderWidth:0
- in:self.
+ corner:(1.0 @ 1.0)
+ borderWidth:0
+ in:self.
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.3).
@@ -112,63 +169,6 @@
ObjectMemory addDependent:self. "to get shutdown-update"
!
-initializeMiddleButtonMenu
- |labels|
-
- labels := resources array:#(
- 'apply change'
- 'apply changes to end'
- 'apply all changes'
- '-'
- 'delete'
- 'delete to end'
- 'delete changes for this class to end'
- 'delete all changes for this class'
- '-'
- 'update'
- 'compress'
- 'compare with current version'
- '-'
- 'make change a patch'
-"/ 'update sourcefile from change'
- '-'
- 'save change in file ...'
- 'save changes to end in file ...'
- 'save changes for this class to end in file ...'
- 'save all changes for this class in file ...'
- '-'
- 'writeback changeFile').
-
- changeListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(
- doApply
- doApplyRest
- doApplyAll
- nil
- doDelete
- doDeleteRest
- doDeleteClassRest
- doDeleteClassAll
- nil
- doUpdate
- doCompress
- doCompare
- nil
- doMakePatch
-"/ doMakePermanent
- nil
- doSave
- doSaveRest
- doSaveClassRest
- doSaveClassAll
- nil
- doWriteBack)
- receiver:self
- for:changeListView)
-!
-
realize
super realize.
self readChangesFileInBackground:true.
@@ -181,32 +181,51 @@
|box|
(what == #aboutToExit) ifTrue:[
- "
- smalltalk is about to shut down -
- - if change list was modified, ask user and save if requested.
- "
- anyChanges ifTrue:[
- shown ifFalse:[
- self unrealize.
- self realize
- ].
- self raise.
+ "
+ smalltalk is about to shut down -
+ - if change list was modified, ask user and save if requested.
+ "
+ anyChanges ifTrue:[
+ shown ifFalse:[
+ self unrealize.
+ self realize
+ ].
+ self raise.
- box := YesNoBox new.
- box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
- box noText:(resources at:'don''t update').
- box okText:(resources at:'update').
- box yesAction:[self writeBackChanges]
- noAction:[].
- box showAtPointer
- ].
- ^ self
+ box := YesNoBox new.
+ box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
+ box noText:(resources at:'don''t update').
+ box okText:(resources at:'update').
+ box yesAction:[self writeBackChanges]
+ noAction:[].
+ box showAtPointer
+ ].
+ ^ self
].
super update:what
! !
!ChangesBrowser methodsFor:'termination'!
+terminate
+ "window manager wants us to go away"
+
+ |box|
+
+ anyChanges ifTrue:[
+ box := OptionBox title:'' numberOfOptions:3.
+ box title:(resources at:'close ChangesBrowser.\\changefile has not been updated from the modified changelist.\\Update before closing ?') withCRs.
+ box buttonTitles:(resources array:#('abort' 'don''t update' 'update')).
+ box actions:(Array with:[^ self]
+ with:[self destroy]
+ with:[self writeBackChanges. self destroy]
+ ).
+ box showAtPointer.
+ ] ifFalse:[
+ self destroy
+ ]
+!
+
destroy
"destroy the receiver; make certain, that boxes are destroyed too"
@@ -221,139 +240,13 @@
send it; instead, they simply destroy the view."
anyChanges ifTrue:[
- self writeBackChanges.
+ self writeBackChanges.
].
self destroy
-!
-
-terminate
- "window manager wants us to go away"
-
- |box|
-
- anyChanges ifTrue:[
- box := OptionBox title:'' numberOfOptions:3.
- box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
- box buttonTitles:(resources array:#('abort' 'dont''t update' 'update')).
- box actions:(Array with:[^ self]
- with:[self destroy]
- with:[self writeBackChanges. self destroy]
- ).
- box showAtPointer.
- ] ifFalse:[
- self destroy
- ]
! !
!ChangesBrowser methodsFor:'private'!
-enableMenuEntries
- "enable all entries refering to a selected change"
-
- #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
- doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
- doSave doSaveRest doSaveClassAll doSaveClassRest)
- do:[:sel |
- changeListView middleButtonMenu enable:sel
- ].
-!
-
-disableMenuEntries
- "enable all entries refering to a selected change"
-
- #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
- doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
- doSave doSaveRest doSaveClassAll doSaveClassRest)
- do:[:sel |
- changeListView middleButtonMenu disable:sel
- ].
-!
-
-unselect
- "common unselect"
-
- changeListView deselect.
- self disableMenuEntries
-!
-
-queryCloseText
- "made this a method for easy redefinition in subclasses"
-
- ^ 'Quit without updating changeFile ?'
-!
-
-changeFileName:aFileName
- changeFileName := aFileName
-!
-
-classNameOfChange:changeNr
- "return the classname of a change (for xxx class - changes xxx is returned)
- - since parsing ascii methods is slow, keep result cached in
- changeClassNames for the next query"
-
- |chunk aParseTree recTree sel name arg1Tree|
-
- changeNr notNil ifTrue:[
- "
- first look, if not already known
- "
- name := changeClassNames at:changeNr.
- name notNil ifTrue:[^ name].
-
- "
- get the chunk
- "
- chunk := changeChunks at:changeNr.
- chunk notNil ifTrue:[
- "
- use parser to construct a parseTree
- "
- aParseTree := Parser parseExpression:chunk.
- (aParseTree notNil and:[aParseTree isMessage]) ifTrue:[
- "
- ask parser for selector
- "
- sel := aParseTree selector.
- "
- is it a method-change, methodRemove or comment-change ?
- "
- (#(methodsFor: privateMethodsFor: publicMethodsFor:
- removeSelector: comment:) includes:sel) ifTrue:[
- "
- yes, the className is the receiver
- "
- recTree := aParseTree receiver.
- (recTree notNil and:[recTree ~~ #Error]) ifTrue:[
- recTree isUnaryMessage ifTrue:[
- (recTree selector ~~ #class) ifTrue:[^ nil].
- "id class methodsFor:..."
- recTree := recTree receiver
- ].
- recTree isPrimary ifTrue:[
- name := recTree name.
- changeClassNames at:changeNr put:name.
- ^ name
- ]
- ]
- ] ifFalse:[
- "
- is it a change in a class-description ?
- "
- ('subclass:*' match:sel) ifTrue:[
- arg1Tree := aParseTree arg1.
- (arg1Tree notNil and:[arg1Tree isConstant]) ifTrue:[
- name := arg1Tree value asString.
- changeClassNames at:changeNr put:name.
- ^ name
- ]
- ]
- ]
- ]
- ]
- ].
- ^ nil
-!
-
streamForChange:changeNr
"answer a stream for change"
@@ -365,6 +258,35 @@
^ aStream
!
+enableMenuEntries
+ "enable all entries refering to a selected change"
+
+ #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
+ doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
+ doSave doSaveRest doSaveClassAll doSaveClassRest doBrowse)
+ do:[:sel |
+ changeListView middleButtonMenu enable:sel
+ ].
+!
+
+unselect
+ "common unselect"
+
+ changeListView deselect.
+ self disableMenuEntries
+!
+
+disableMenuEntries
+ "enable all entries refering to a selected change"
+
+ #(doApply doApplyRest doDelete doDeleteRest doDeleteClassRest
+ doDeleteClassAll doCompare doMakePatch doSaveChangeInFile doMakePermanent
+ doSave doSaveRest doSaveClassAll doSaveClassRest doBrowse)
+ do:[:sel |
+ changeListView middleButtonMenu disable:sel
+ ].
+!
+
clearCodeView
self unselect "changeListView deselect".
codeView contents:nil.
@@ -373,83 +295,26 @@
autoSelect:changeNr
self class autoSelectNext ifTrue:[
- (changeNr <= changeChunks size) ifTrue:[
- self clearCodeView.
- changeListView selection:changeNr.
- self changeSelection:changeNr.
- ^ self
- ]
+ (changeNr <= changeChunks size) ifTrue:[
+ self clearCodeView.
+ changeListView selection:changeNr.
+ self changeSelection:changeNr.
+ ^ self
+ ]
].
self clearCodeView
!
-writeBackChanges
- "write back the changes file"
-
- |inStream outStream chunk sawExcla excla done dir|
-
- outStream := FileStream newFileNamed:'n_changes'.
- outStream isNil ifTrue:[
- self warn:'cannot create temporary file'.
- ^ self
- ].
-
- inStream := FileStream readonlyFileNamed:changeFileName.
- inStream isNil ifTrue:[^ nil].
-
- self withCursor:(Cursor write) do:[
- excla := inStream class chunkSeparator.
- 1 to:(changeChunks size) do:[:index |
- inStream position:(changePositions at:index).
- sawExcla := inStream peekFor:excla.
- chunk := inStream nextChunk.
-
- sawExcla ifTrue:[
- outStream nextPut:excla.
- outStream nextChunkPut:chunk.
- outStream cr.
- "a method-definition chunk - skip followups"
- done := false.
- [done] whileFalse:[
- chunk := inStream nextChunk.
- chunk isNil ifTrue:[
- done := true
- ] ifFalse:[
- outStream nextChunkPut:chunk.
- outStream cr.
- done := chunk isEmpty
- ]
- ].
- ] ifFalse:[
- outStream nextChunkPut:chunk.
- outStream cr
- ]
- ].
- outStream close.
- inStream close.
- dir := FileDirectory currentDirectory.
-"/ dir removeFile:changeFileName.
- dir renameFile:'changes' newName:'changes.bak'.
- dir renameFile:'n_changes' newName:changeFileName.
- anyChanges := false
+autoSelectOrEnd:changeNr
+ changeNr < changeChunks size ifTrue:[
+ self autoSelect:changeNr
+ ] ifFalse:[
+ self clearCodeView.
+ changeListView selection:changeChunks size.
+ self changeSelection:changeChunks size.
]
!
-setChangeList
- "extract type-information from changes and stuff into top selection
- view"
-
- changeListView contents:changeHeaderLines "changeChunks".
- self disableMenuEntries
-!
-
-readChangesFile
- "read the changes file, create a list of header-lines (changeChunks)
- and a list of chunk-positions (changePositions)"
-
- ^ self readChangesFileInBackground:false
-!
-
readChangesFileInBackground:inBackground
"read the changes file, create a list of header-lines (changeChunks)
and a list of chunk-positions (changePositions)"
@@ -461,125 +326,180 @@
aStream isNil ifTrue:[^ nil].
self withCursor:(Cursor read) do:[
- "
- this is a time consuming operation (especially, if reading an
- NFS-mounted directory; therefore lower my priority ...
- "
- inBackground ifTrue:[
- myProcess := Processor activeProcess.
- myPriority := myProcess priority.
- myProcess priority:(Processor userBackgroundPriority).
- ].
- [
- changeChunks := OrderedCollection new.
- changeHeaderLines := OrderedCollection new.
- changePositions := OrderedCollection new.
- excla := aStream class chunkSeparator.
+ "
+ this is a time consuming operation (especially, if reading an
+ NFS-mounted directory; therefore lower my priority ...
+ "
+ inBackground ifTrue:[
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+ ].
+ [
+ changeChunks := OrderedCollection new.
+ changeHeaderLines := OrderedCollection new.
+ changePositions := OrderedCollection new.
+ excla := aStream class chunkSeparator.
- [aStream atEnd] whileFalse:[
- "
- get a chunk (separated by excla)
- "
- aStream skipSeparators.
- chunkPos := aStream position.
- sawExcla := aStream peekFor:excla.
- chunkText := aStream nextChunk.
- chunkText notNil ifTrue:[
- "
- only first line is saved in changeChunks ...
- "
- index := chunkText indexOf:(Character cr).
- (index ~~ 0) ifTrue:[
- chunkText := chunkText copyTo:(index - 1).
+ [aStream atEnd] whileFalse:[
+ "
+ get a chunk (separated by excla)
+ "
+ aStream skipSeparators.
+ chunkPos := aStream position.
+ sawExcla := aStream peekFor:excla.
+ chunkText := aStream nextChunk.
+ chunkText notNil ifTrue:[
+ "
+ only first line is saved in changeChunks ...
+ "
+ index := chunkText indexOf:(Character cr).
+ (index ~~ 0) ifTrue:[
+ chunkText := chunkText copyTo:(index - 1).
+
+ "take care for comment changes - must still be a
+ valid expression for classNameOfChange: to work"
+
+ (chunkText endsWith:'comment:''') ifTrue:[
+ chunkText := chunkText , '...'''
+ ]
- "take care for comment changes - must still be a
- valid expression for classNameOfChange: to work"
+ ].
+
+ changeChunks add:chunkText.
+ changePositions add:chunkPos.
- (chunkText endsWith:'comment:''') ifTrue:[
- chunkText := chunkText , '...'''
- ]
-
- ].
-
- changeChunks add:chunkText.
- changePositions add:chunkPos.
+ sawExcla ifFalse:[
+ (chunkText startsWith:'''---- snap') ifFalse:[
+ headerLine := chunkText , ' (doIt)'
+ ] ifTrue:[
+ headerLine := chunkText
+ ].
+ changeHeaderLines add:headerLine.
+ ] ifTrue:[
+ "
+ method definitions actually consist of
+ two (or more) chunks; skip next chunk(s)
+ up to an empty one.
+ The system only writes one chunk,
+ and we cannot handle more in this ChangesBrowser ....
+ "
+ cls := nil.
+ p := Parser parseExpression:chunkText.
- sawExcla ifFalse:[
- (chunkText startsWith:'''---- snap') ifFalse:[
- headerLine := chunkText , ' (doIt)'
- ] ifTrue:[
- headerLine := chunkText
- ].
- changeHeaderLines add:headerLine.
- ] ifTrue:[
- "
- method definitions actually consist of
- two (or more) chunks; skip next chunk(s)
- up to an empty one.
- The system only writes one chunk,
- and we cannot handle more in this ChangesBrowser ....
- "
- cls := nil.
- p := Parser parseExpression:chunkText.
+ (p notNil and:[p ~~ #Error]) ifTrue:[
+ sel := p selector.
+ (sel == #methodsFor:) ifTrue:[
+ p receiver isUnaryMessage ifTrue:[
+ cls := p receiver receiver name.
+ cls := cls , 'class'
+ ] ifFalse:[
+ cls := p receiver name
+ ].
+ category := (p args at:1) evaluate.
+ ]
+ ].
+ done := false.
+ first := true.
+ [done] whileFalse:[
+ text := aStream nextChunk.
+ text isNil ifTrue:[
+ done := true
+ ] ifFalse:[
+ done := text isEmpty
+ ].
+ done ifFalse:[
+ first ifFalse:[
+ Transcript showCr:'only one method per ''methodsFor:'' handled'.
+ ] ifTrue:[
+ first := false.
+ "
+ try to find the selector
+ "
+ sel := nil.
+ cls notNil ifTrue:[
+ p := Parser
+ parseMethodSpecification:text
+ in:nil
+ ignoreErrors:true
+ ignoreWarnings:true.
+ (p notNil and:[p ~~ #Error]) ifTrue:[
+ sel := p selector.
+ ]
+ ].
+ sel isNil ifTrue:[
+ changeHeaderLines add:chunkText , ' (change)'.
+ ] ifFalse:[
+ changeHeaderLines add:cls , ' ' , sel , ' ' , '(change category: ''' , category , ''')'.
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ changeClassNames := OrderedCollection new grow:(changeChunks size).
+ aStream close.
+ anyChanges := false
+ ] valueNowOrOnUnwindDo:[
+ inBackground ifTrue:[myProcess priority:myPriority].
+ ].
+ ]
+!
- (p notNil and:[p ~~ #Error]) ifTrue:[
- sel := p selector.
- (sel == #methodsFor:) ifTrue:[
- p receiver isUnaryMessage ifTrue:[
- cls := p receiver receiver name.
- cls := cls , 'class'
- ] ifFalse:[
- cls := p receiver name
- ].
- category := (p args at:1) evaluate.
- ]
- ].
- done := false.
- first := true.
- [done] whileFalse:[
- text := aStream nextChunk.
- text isNil ifTrue:[
- done := true
- ] ifFalse:[
- done := text isEmpty
- ].
- done ifFalse:[
- first ifFalse:[
- Transcript showCr:'only one method per ''methodsFor:'' handled'.
- ] ifTrue:[
- first := false.
- "
- try to find the selector
- "
- sel := nil.
- cls notNil ifTrue:[
- p := Parser
- parseMethodSpecification:text
- in:nil
- ignoreErrors:true
- ignoreWarnings:true.
- (p notNil and:[p ~~ #Error]) ifTrue:[
- sel := p selector.
- ]
- ].
- sel isNil ifTrue:[
- changeHeaderLines add:chunkText , ' (change)'.
- ] ifFalse:[
- changeHeaderLines add:cls , ' ' , sel , ' ' , '(change category: ''' , category , ''')'.
- ]
- ]
- ]
- ]
- ]
- ]
- ].
- changeClassNames := OrderedCollection new grow:(changeChunks size).
- aStream close.
- anyChanges := false
- ] valueNowOrOnUnwindDo:[
- inBackground ifTrue:[myProcess priority:myPriority].
- ].
- ]
+queryCloseText
+ "made this a method for easy redefinition in subclasses"
+
+ ^ 'Quit without updating changeFile ?'
+!
+
+applyChange:changeNr
+ "fileIn a change"
+
+ |aStream upd sig nm cls|
+
+ aStream := self streamForChange:changeNr.
+ aStream isNil ifTrue:[^ self].
+
+ nm := self classNameOfChange:changeNr.
+ nm notNil ifTrue:[
+ cls := Smalltalk at:(nm asSymbol) ifAbsent:[].
+ cls notNil ifTrue:[
+ cls isLoaded ifFalse:[
+ cls autoload
+ ]
+ ]
+ ].
+
+ upd := Class updateChanges:false.
+
+ changeNrProcessed := changeNr.
+ [
+ (skipSignal notNil) ifTrue:[
+ sig := skipSignal
+ ] ifFalse:[
+ sig := Object abortSignal
+ ].
+ sig catch:[
+ aStream fileInNextChunkNotifying:self
+ ].
+ changeNrProcessed := nil.
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd.
+ aStream close
+ ].
+!
+
+changeFileName:aFileName
+ changeFileName := aFileName
+!
+
+setChangeList
+ "extract type-information from changes and stuff into top selection
+ view"
+
+ changeListView contents:changeHeaderLines "changeChunks".
+ self disableMenuEntries
!
silentDeleteChange:changeNr
@@ -592,13 +512,133 @@
changeHeaderLines removeIndex:changeNr
!
+writeBackChanges
+ "write back the changes file"
+
+ |inStream outStream chunk sawExcla excla done dir|
+
+ outStream := FileStream newFileNamed:'n_changes'.
+ outStream isNil ifTrue:[
+ self warn:'cannot create temporary file'.
+ ^ self
+ ].
+
+ inStream := FileStream readonlyFileNamed:changeFileName.
+ inStream isNil ifTrue:[^ nil].
+
+ self withCursor:(Cursor write) do:[
+ excla := inStream class chunkSeparator.
+ 1 to:(changeChunks size) do:[:index |
+ inStream position:(changePositions at:index).
+ sawExcla := inStream peekFor:excla.
+ chunk := inStream nextChunk.
+
+ sawExcla ifTrue:[
+ outStream nextPut:excla.
+ outStream nextChunkPut:chunk.
+ outStream cr.
+ "a method-definition chunk - skip followups"
+ done := false.
+ [done] whileFalse:[
+ chunk := inStream nextChunk.
+ chunk isNil ifTrue:[
+ done := true
+ ] ifFalse:[
+ outStream nextChunkPut:chunk.
+ outStream cr.
+ done := chunk isEmpty
+ ]
+ ].
+ ] ifFalse:[
+ outStream nextChunkPut:chunk.
+ outStream cr
+ ]
+ ].
+ outStream close.
+ inStream close.
+ dir := FileDirectory currentDirectory.
+"/ dir removeFile:changeFileName.
+ dir renameFile:'changes' newName:'changes.bak'.
+ dir renameFile:'n_changes' newName:changeFileName.
+ anyChanges := false
+ ]
+!
deleteChange:changeNr
"delete a change"
changeListView deselect.
self silentDeleteChange:changeNr.
- changeListView setContents:changeChunks
+ self setChangeList "/changeListView setContents:changeChunks
+
+!
+
+classNameOfChange:changeNr
+ "return the classname of a change (for xxx class - changes xxx is returned)
+ - since parsing ascii methods is slow, keep result cached in
+ changeClassNames for the next query"
+
+ |chunk aParseTree recTree sel name arg1Tree|
+
+ changeNr notNil ifTrue:[
+ "
+ first look, if not already known
+ "
+ name := changeClassNames at:changeNr.
+ name notNil ifTrue:[^ name].
+
+ "
+ get the chunk
+ "
+ chunk := changeChunks at:changeNr.
+ chunk notNil ifTrue:[
+ "
+ use parser to construct a parseTree
+ "
+ aParseTree := Parser parseExpression:chunk.
+ (aParseTree notNil and:[aParseTree isMessage]) ifTrue:[
+ "
+ ask parser for selector
+ "
+ sel := aParseTree selector.
+ "
+ is it a method-change, methodRemove or comment-change ?
+ "
+ (#(methodsFor: privateMethodsFor: publicMethodsFor:
+ removeSelector: comment:) includes:sel) ifTrue:[
+ "
+ yes, the className is the receiver
+ "
+ recTree := aParseTree receiver.
+ (recTree notNil and:[recTree ~~ #Error]) ifTrue:[
+ recTree isUnaryMessage ifTrue:[
+ (recTree selector ~~ #class) ifTrue:[^ nil].
+ "id class methodsFor:..."
+ recTree := recTree receiver
+ ].
+ recTree isPrimary ifTrue:[
+ name := recTree name.
+ changeClassNames at:changeNr put:name.
+ ^ name
+ ]
+ ]
+ ] ifFalse:[
+ "
+ is it a change in a class-description ?
+ "
+ ('subclass:*' match:sel) ifTrue:[
+ arg1Tree := aParseTree arg1.
+ (arg1Tree notNil and:[arg1Tree isConstant]) ifTrue:[
+ name := arg1Tree value asString.
+ changeClassNames at:changeNr put:name.
+ ^ name
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ nil
!
deleteChangesFrom:start to:stop
@@ -606,58 +646,17 @@
changeListView deselect.
stop to:start by:-1 do:[:changeNr |
- self silentDeleteChange:changeNr
+ self silentDeleteChange:changeNr
].
- changeListView setContents:changeChunks
-!
-
-deleteChangesFor:aClassName from:start to:stop
- "delete changes for a given class in a range"
+ self setChangeList "/changeListView setContents:changeChunks
- |thisClassName index|
-
- index := stop.
- [index >= start] whileTrue:[
- thisClassName := self classNameOfChange:index.
- thisClassName = aClassName ifTrue:[
- self silentDeleteChange:index
- ].
- index := index - 1
- ]
!
-applyChange:changeNr
- "filein a change"
-
- |aStream chunk sawExcla upd rslt|
-
- aStream := self streamForChange:changeNr.
- aStream isNil ifTrue:[^ self].
- sawExcla := aStream peekFor:(aStream class chunkSeparator).
- chunk := aStream nextChunk.
- upd := Class updateChanges:false.
-
- codeView abortAction:[Class updateChanges:upd.
- codeView abortAction:nil.
- aStream close.
- ^self].
+readChangesFile
+ "read the changes file, create a list of header-lines (changeChunks)
+ and a list of chunk-positions (changePositions)"
- changeNrProcessed := changeNr.
- [
- Object abortSignal catch:[
- |rslt|
-
- rslt := Compiler evaluate:chunk notifying:self.
- sawExcla ifTrue:[
- rslt fileInFrom:aStream notifying:self
- ]
- ].
- changeNrProcessed := nil.
- codeView abortAction:nil
- ] valueNowOrOnUnwindDo:[
- Class updateChanges:upd.
- aStream close
- ].
+ ^ self readChangesFileInBackground:false
!
compareChange:changeNr
@@ -672,50 +671,50 @@
sawExcla := aStream peekFor:(aStream class chunkSeparator).
chunk := aStream nextChunk.
sawExcla ifFalse:[
- outcome := 'not comparable ...'
+ outcome := 'not comparable ...'
] ifTrue:[
- parseTree := Parser parseExpression:chunk.
- (parseTree notNil and:[parseTree isMessage]) ifTrue:[
- (parseTree selector == #methodsFor:) ifTrue:[
- thisClass := (parseTree receiver evaluate).
- thisClass isBehavior ifTrue:[
- showDiff := false.
- cat := parseTree arg1 evaluate.
- newSource := aStream nextChunk.
- parser := Parser parseMethod:newSource in:thisClass.
- (parser notNil and:[parser ~~ #Error]) ifTrue:[
- sel := parser selector.
- oldMethod := thisClass compiledMethodAt:sel.
- oldMethod notNil ifTrue:[
- (oldMethod category = cat) ifFalse:[
- Transcript showCr:'category changed.'.
- ].
- oldSource := oldMethod source.
- (oldSource = newSource) ifTrue:[
- outcome := 'same source'
- ] ifFalse:[
- outcome := 'source changed.'.
- showDiff := true
- ]
- ] ifFalse:[
- outcome := 'method does not exist.'
- ]
- ] ifFalse:[
- outcome := 'change unparsable.'
- ].
- (showDiff and:[oldSource notNil and:[newSource notNil]]) ifTrue:[
- d := DiffTextView openOn:oldSource and:newSource.
- d label:'differences (current left; change right)'.
- ]
- ] ifFalse:[
- outcome := 'class does not exist.'
- ]
- ] ifFalse:[
- outcome := 'not comparable.'
- ]
- ] ifFalse:[
- outcome := 'not comparable.'
- ]
+ parseTree := Parser parseExpression:chunk.
+ (parseTree notNil and:[parseTree isMessage]) ifTrue:[
+ (parseTree selector == #methodsFor:) ifTrue:[
+ thisClass := (parseTree receiver evaluate).
+ thisClass isBehavior ifTrue:[
+ showDiff := false.
+ cat := parseTree arg1 evaluate.
+ newSource := aStream nextChunk.
+ parser := Parser parseMethod:newSource in:thisClass.
+ (parser notNil and:[parser ~~ #Error]) ifTrue:[
+ sel := parser selector.
+ oldMethod := thisClass compiledMethodAt:sel.
+ oldMethod notNil ifTrue:[
+ (oldMethod category = cat) ifFalse:[
+ Transcript showCr:'category changed.'.
+ ].
+ oldSource := oldMethod source.
+ (oldSource = newSource) ifTrue:[
+ outcome := 'same source'
+ ] ifFalse:[
+ outcome := 'source changed.'.
+ showDiff := true
+ ]
+ ] ifFalse:[
+ outcome := 'method does not exist.'
+ ]
+ ] ifFalse:[
+ outcome := 'change unparsable.'
+ ].
+ (showDiff and:[oldSource notNil and:[newSource notNil]]) ifTrue:[
+ d := DiffTextView openOn:oldSource and:newSource.
+ d label:'differences (current left; change right)'.
+ ]
+ ] ifFalse:[
+ outcome := 'class does not exist.'
+ ]
+ ] ifFalse:[
+ outcome := 'not comparable.'
+ ]
+ ] ifFalse:[
+ outcome := 'not comparable.'
+ ]
].
Transcript showCr:outcome.
aStream close.
@@ -728,38 +727,38 @@
outStream := FileStream oldFileNamed:fileName.
outStream isNil ifTrue:[
- outStream isNil ifTrue:[
- outStream := FileStream newFileNamed:fileName.
- outStream isNil ifTrue:[
- self warn:'cannot update file ''', fileName , ''''.
- ^ false
- ]
- ]
+ outStream isNil ifTrue:[
+ outStream := FileStream newFileNamed:fileName.
+ outStream isNil ifTrue:[
+ self warn:'cannot update file ''%1''' with:fileName.
+ ^ false
+ ]
+ ]
].
outStream setToEnd.
aStream := self streamForChange:changeNr.
aStream isNil ifTrue:[
- self warn:'oops cannot read change'.
- ^ false
+ self warn:'oops cannot read change'.
+ ^ false
].
separator := aStream class chunkSeparator.
sawExcla := aStream peekFor:separator.
sawExcla ifTrue:[
- outStream nextPut:separator
+ outStream nextPut:separator
].
chunk := aStream nextChunk.
outStream nextChunkPut:chunk.
outStream cr.
sawExcla ifTrue:[
- chunk := aStream nextChunk.
- outStream nextChunkPut:chunk.
- outStream space
+ chunk := aStream nextChunk.
+ outStream nextChunkPut:chunk.
+ outStream space
].
sawExcla ifTrue:[
- outStream nextPut:separator
+ outStream nextPut:separator
].
outStream cr.
aStream close.
@@ -777,48 +776,26 @@
"rewrite the source file where change changeNr lies"
self notify:'this is not yet implemented'
-! !
-
-!ChangesBrowser methodsFor:'error handling'!
-
-correctableError:aString position:relPos to:relEndPos
- "compiler notifys us of an error - this should really not happen since
- changes ought to be correct (did someone edit the changes file ??).
- Show the bad change in the codeView and let codeView hilight the error;
- no corrections allowed here therefore return false"
-
- (changeNrProcessed ~~ changeNrShown) ifTrue:[
- self changeSelection:changeNrProcessed
- ].
- codeView error:aString position:relPos to:relEndPos.
- ^ false
!
-error:aString position:relPos to:relEndPos
- "compiler notifys us of an error - this should really not happen since
- changes ought to be correct (did someone edit the changes file ??).
- Show the bad change in the codeView and let codeView hilight the error"
+silentDeleteChangesFor:aClassName from:start to:stop
+ "delete changes for a given class in a range"
+
+ |thisClassName index|
- (changeNrProcessed ~~ changeNrShown) ifTrue:[
- self changeSelection:changeNrProcessed
- ].
- ^ codeView error:aString position:relPos to:relEndPos
-!
+ index := stop.
+ [index >= start] whileTrue:[
+ thisClassName := self classNameOfChange:index.
+ thisClassName = aClassName ifTrue:[
+ self silentDeleteChange:index
+ ].
+ index := index - 1
+ ]
-warning:aString position:relPos to:relEndPos
- "compiler notifys us of a warning - ignore it"
-
- ^ self
! !
!ChangesBrowser methodsFor:'user interaction'!
-noChangesAllowed
- "show a warning that changes cannot be changed"
-
- self warn:(resources at:'changes are not allowed to be changed')
-!
-
changeSelection:lineNr
"show a change in the codeView"
@@ -829,7 +806,7 @@
sawExcla := aStream peekFor:(aStream class chunkSeparator).
chunk := aStream nextChunk.
sawExcla ifTrue:[
- chunk := aStream nextChunk
+ chunk := aStream nextChunk
].
aStream close.
codeView contents:chunk.
@@ -838,6 +815,12 @@
self enableMenuEntries
!
+noChangesAllowed
+ "show a warning that changes cannot be changed"
+
+ self warn:'changes are not allowed to be changed'
+!
+
doSaveClass
"user wants changes for some class from current to end to be appended to a file"
@@ -850,6 +833,21 @@
self doSaveClassFrom:1
!
+doApply
+ "user wants a change to be applied"
+
+ |changeNr|
+
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ self withCursor:(Cursor execute) do:[
+ skipSignal := nil.
+ self applyChange:changeNr.
+ self autoSelect:(changeNr + 1)
+ ]
+ ]
+!
+
doSaveClassRest
"user wants changes for some class from current to end to be appended to a file"
@@ -857,7 +855,7 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self doSaveClassFrom:changeNr
+ self doSaveClassFrom:changeNr
]
!
@@ -868,27 +866,43 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- fileBox := FileSelectionBox new.
- fileBox title:'append change to:'.
- fileBox okText:'append'.
- fileBox abortText:'cancel'.
- fileBox action:[:fileName |
- |thisClassName|
- self withCursor:(Cursor write) do:[
- startNr to:(changeChunks size) do:[:changeNr |
- thisClassName := self classNameOfChange:changeNr.
- thisClassName = aClassName ifTrue:[
- changeListView selection:changeNr.
- (self appendChange:changeNr toFile:fileName) ifFalse:[
- ^ self
- ]
- ]
- ]
- ]
- ].
+ fileBox := FileSelectionBox new.
+ fileBox title:'append change to:'.
+ fileBox okText:'append'.
+ fileBox abortText:'cancel'.
+ fileBox action:[:fileName |
+ |thisClassName|
+ self withCursor:(Cursor write) do:[
+ startNr to:(changeChunks size) do:[:changeNr |
+ thisClassName := self classNameOfChange:changeNr.
+ thisClassName = aClassName ifTrue:[
+ changeListView selection:changeNr.
+ (self appendChange:changeNr toFile:fileName) ifFalse:[
+ ^ self
+ ]
+ ]
+ ]
+ ]
+ ].
- fileBox pattern:'*.chg'.
- fileBox showAtPointer
+ fileBox pattern:'*.chg'.
+ fileBox showAtPointer
+ ]
+!
+
+doBrowse
+ "user wants a browser on the class of a change"
+
+ |changeNr className cls|
+
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ className := self classNameOfChange:changeNr.
+ className notNil ifTrue:[
+ (cls := Smalltalk classNamed:className) notNil ifTrue:[
+ SystemBrowser browseClass:cls
+ ]
+ ]
]
!
@@ -899,10 +913,10 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- classNameToSave := self classNameOfChange:changeNr.
- classNameToSave notNil ifTrue:[
- self saveClass:classNameToSave from:startNr
- ]
+ classNameToSave := self classNameOfChange:changeNr.
+ classNameToSave notNil ifTrue:[
+ self saveClass:classNameToSave from:startNr
+ ]
]
!
@@ -913,23 +927,23 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- fileBox := FileSelectionBox new.
- fileBox title:'append change to:'.
- fileBox okText:'append'.
- fileBox abortText:'cancel'.
- fileBox action:[:fileName |
- self withCursor:(Cursor write) do:[
- changeNr to:(changeChunks size) do:[:changeNr |
- changeListView selection:changeNr.
- (self appendChange:changeNr toFile:fileName) ifFalse:[
- ^ self
- ]
- ]
- ]
- ].
+ fileBox := FileSelectionBox new.
+ fileBox title:'append change to:'.
+ fileBox okText:'append'.
+ fileBox abortText:'cancel'.
+ fileBox action:[:fileName |
+ self withCursor:(Cursor write) do:[
+ changeNr to:(changeChunks size) do:[:changeNr |
+ changeListView selection:changeNr.
+ (self appendChange:changeNr toFile:fileName) ifFalse:[
+ ^ self
+ ]
+ ]
+ ]
+ ].
- fileBox pattern:'*.chg'.
- fileBox showAtPointer
+ fileBox pattern:'*.chg'.
+ fileBox showAtPointer
]
!
@@ -940,19 +954,19 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- fileBox := FileSelectionBox new.
- fileBox title:'append change to:'.
- fileBox okText:'append'.
- fileBox abortText:'cancel'.
- fileBox action:[:fileName |
- self withCursor:(Cursor write) do:[
- self appendChange:changeNr toFile:fileName.
- ].
- self autoSelect:(changeNr + 1)
- ].
+ fileBox := FileSelectionBox new.
+ fileBox title:'append change to:'.
+ fileBox okText:'append'.
+ fileBox abortText:'cancel'.
+ fileBox action:[:fileName |
+ self withCursor:(Cursor write) do:[
+ self appendChange:changeNr toFile:fileName.
+ ].
+ self autoSelect:(changeNr + 1)
+ ].
- fileBox pattern:'*.chg'.
- fileBox showAtPointer
+ fileBox pattern:'*.chg'.
+ fileBox showAtPointer
]
!
@@ -967,12 +981,12 @@
yesNoBox okText:(resources at:'continue').
yesNoBox noText:(resources at:'abort').
yesNoBox okAction:[
- changeNr := changeListView selection.
- changeNr notNil ifTrue:[
- self makeChangePermanent:changeNr.
- self autoSelect:(changeNr + 1)
- ]
- ].
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ self makeChangePermanent:changeNr.
+ self autoSelect:(changeNr + 1)
+ ]
+ ].
yesNoBox showAtPointer
!
@@ -984,51 +998,8 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self makeChangeAPatch:changeNr.
- self autoSelect:(changeNr + 1)
- ]
-!
-
-doApply
- "user wants a change to be applied"
-
- |changeNr|
-
- changeNr := changeListView selection.
- changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- self applyChange:changeNr.
- self autoSelect:(changeNr + 1)
- ]
- ]
-!
-
-doApplyAll
- "user wants all changes to be applied"
-
- self withCursor:(Cursor execute) do:[
- self clearCodeView.
- 1 to:(changePositions size) do:[:changeNr |
- changeListView selection:changeNr.
- self applyChange:changeNr
- ]
- ]
-!
-
-doApplyRest
- "user wants all changes from changeNr to be applied"
-
- |changeNr|
-
- changeNr := changeListView selection.
- changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- self clearCodeView.
- changeNr to:(changePositions size) do:[:changeNr |
- changeListView selection:changeNr.
- self applyChange:changeNr
- ]
- ]
+ self makeChangeAPatch:changeNr.
+ self autoSelect:(changeNr + 1)
]
!
@@ -1039,8 +1010,45 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self deleteChange:changeNr.
- self autoSelect:changeNr
+ self deleteChange:changeNr.
+ self autoSelectOrEnd:changeNr
+ ]
+!
+
+doApplyRest
+ "user wants all changes from changeNr to be applied"
+
+ |changeNr|
+
+ changeNr := changeListView selection.
+ changeNr notNil ifTrue:[
+ self withCursor:(Cursor execute) do:[
+ self clearCodeView.
+ skipSignal isNil ifTrue:[skipSignal := Signal new].
+"/ Object abortSignal catch:[
+ changeNr to:(changePositions size) do:[:changeNr |
+ changeListView selection:changeNr.
+ self applyChange:changeNr
+"/ ]
+ ].
+"/ skipSignal := nil
+ ]
+ ]
+!
+
+doApplyAll
+ "user wants all changes to be applied"
+
+ self withCursor:(Cursor execute) do:[
+ self clearCodeView.
+ skipSignal isNil ifTrue:[skipSignal := Signal new].
+"/ Object abortSignal catch:[
+ 1 to:(changePositions size) do:[:changeNr |
+ changeListView selection:changeNr.
+ self applyChange:changeNr
+"/ ]
+ ].
+"/ skipSignal := nil
]
!
@@ -1051,17 +1059,31 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- classNameToDelete := self classNameOfChange:changeNr.
- classNameToDelete notNil ifTrue:[
- changeListView selection:nil.
- self deleteChangesFor:classNameToDelete
- from:changeNr
- to:(changeChunks size).
- changeListView setContents:changeChunks.
- self autoSelect:changeNr
- ]
- ]
+ self withCursor:(Cursor execute) do:[
+ classNameToDelete := self classNameOfChange:changeNr.
+ classNameToDelete notNil ifTrue:[
+ changeListView selection:nil.
+ self silentDeleteChangesFor:classNameToDelete
+ from:changeNr
+ to:(changeChunks size).
+ self setChangeList. "/changeListView setContents:changeChunks.
+ self autoSelectOrEnd:changeNr
+ ]
+ ]
+ ]
+!
+
+doWriteBack
+ "write back the list onto the changes file"
+
+ anyChanges ifTrue:[
+ self writeBackChanges.
+ realized ifTrue:[
+ self readChangesFileInBackground:false.
+ realized ifTrue:[
+ self setChangeList
+ ]
+ ]
]
!
@@ -1072,8 +1094,152 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self deleteChangesFrom:changeNr to:(changeChunks size).
- self clearCodeView
+ self deleteChangesFrom:changeNr to:(changeChunks size).
+ self clearCodeView.
+ self autoSelectOrEnd:changeNr-1
+ ]
+!
+
+doCompress
+ "compress the change-set; this replaces multiple method-changes by the last
+ (i.e. the most recent) change"
+
+ |classes types selectors thisClass thisSelector
+ aStream chunk changeNr sawExcla aParseTree codeChunk codeParser
+ searchIndex anyMore deleteSet index parseTreeChunk numChanges
+ excla snapshotProto str snapshotPrefix snapshotNameIndex fileName|
+
+ aStream := FileStream readonlyFileNamed:changeFileName.
+ aStream isNil ifTrue:[^ self].
+
+ "
+ get a prototype snapshot record (to be independent of
+ the actual format ..
+ "
+ str := WriteStream on:String new.
+ Class addChangeRecordForSnapshot:'foo' to:str.
+ snapshotProto := str contents.
+ snapshotPrefix := snapshotProto copyTo:10.
+ snapshotNameIndex := snapshotProto findString:'foo'.
+
+ self withCursor:(Cursor execute) do:[
+ numChanges := changePositions size.
+ classes := Array new:numChanges.
+ selectors := Array new:numChanges.
+ types := Array new:numChanges.
+
+ "starting at the end, get the change class and change selector;
+ collect all in classes / selectors"
+
+ changeNr := numChanges.
+ excla := aStream class chunkSeparator.
+
+ [changeNr >= 1] whileTrue:[
+ aStream position:(changePositions at:changeNr).
+ sawExcla := aStream peekFor:excla.
+ chunk := aStream nextChunk.
+ sawExcla ifTrue:[
+ "optimize a bit if multiple methods for same category arrive"
+ (chunk = parseTreeChunk) ifFalse:[
+ aParseTree := Parser parseExpression:chunk.
+ parseTreeChunk := chunk
+ ].
+ (aParseTree notNil
+ and:[(aParseTree ~~ #Error)
+ and:[aParseTree isMessage]]) ifTrue:[
+ (aParseTree selector == #methodsFor:) ifTrue:[
+ thisClass := (aParseTree receiver evaluate).
+ codeChunk := aStream nextChunk.
+ codeParser := Parser
+ parseMethodSpecification:codeChunk
+ in:thisClass
+ ignoreErrors:true
+ ignoreWarnings:true.
+ codeParser notNil ifTrue:[
+ selectors at:changeNr put:(codeParser selector).
+ classes at:changeNr put:thisClass.
+ types at:changeNr put:#methodsFor
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ aParseTree := Parser parseExpression:chunk.
+ parseTreeChunk := chunk.
+ (aParseTree notNil
+ and:[(aParseTree ~~ #Error)
+ and:[aParseTree isMessage]]) ifTrue:[
+ (aParseTree selector == #removeSelector:) ifTrue:[
+ selectors at:changeNr put:(aParseTree arg1 value ).
+ classes at:changeNr put:(aParseTree receiver evaluate).
+ types at:changeNr put:#removeSelector
+ ]
+ ] ifFalse:[
+ (chunk startsWith:snapshotPrefix) ifTrue:[
+ str := chunk readStream position:snapshotNameIndex.
+ fileName := str upTo:(Character space).
+ "
+ kludge to allow use of match-check below
+ "
+ selectors at:changeNr put:snapshotPrefix.
+ classes at:changeNr put:fileName.
+ ]
+ ]
+ ].
+ changeNr := changeNr - 1
+ ].
+ aStream close.
+
+ "for all changes, look for another class/selector occurence later
+ in the list and, if there is one, add change number to the delete set"
+
+ deleteSet := OrderedCollection new.
+ changeNr := 1.
+ [changeNr < changePositions size] whileTrue:[
+ thisClass := classes at:changeNr.
+ thisSelector := selectors at:changeNr.
+ searchIndex := changeNr.
+ anyMore := true.
+ [anyMore] whileTrue:[
+ searchIndex := classes indexOf:thisClass
+ startingAt:(searchIndex + 1).
+ (searchIndex ~~ 0) ifTrue:[
+ ((selectors at:searchIndex) == thisSelector) ifTrue:[
+ thisClass notNil ifTrue:[
+ deleteSet add:changeNr.
+ anyMore := false
+ ]
+ ]
+ ] ifFalse:[
+ anyMore := false
+ ]
+ ].
+ changeNr := changeNr + 1
+ ].
+
+ "finally delete what has been found"
+
+ (deleteSet size > 0) ifTrue:[
+ changeListView selection:nil.
+ index := deleteSet size.
+ [index > 0] whileTrue:[
+ self silentDeleteChange:(deleteSet at:index).
+ index := index - 1
+ ].
+ self setChangeList.
+ changeListView firstLineShown > changeChunks size ifTrue:[
+ changeListView makeLineVisible:changeChunks size
+ ].
+ self clearCodeView
+ ]
+ ]
+!
+
+doUpdate
+ "reread the changes-file"
+
+ self readChangesFileInBackground:true.
+ realized ifTrue:[
+ self setChangeList
]
!
@@ -1084,38 +1250,17 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- classNameToDelete := self classNameOfChange:changeNr.
- classNameToDelete notNil ifTrue:[
- changeListView selection:nil.
- self deleteChangesFor:classNameToDelete
- from:1
- to:(changeChunks size).
- changeListView contents:changeChunks.
- self autoSelect:changeNr
- ]
- ]
- ]
-!
-
-doWriteBack
- "write back the list onto the changes file"
-
- anyChanges ifTrue:[
- self writeBackChanges.
- realized ifTrue:[
- self readChangesFileInBackground:false.
- self setChangeList
- ]
- ]
-!
-
-doUpdate
- "reread the changes-file"
-
- self readChangesFileInBackground:true.
- realized ifTrue:[
- self setChangeList
+ self withCursor:(Cursor execute) do:[
+ classNameToDelete := self classNameOfChange:changeNr.
+ classNameToDelete notNil ifTrue:[
+ changeListView selection:nil.
+ self silentDeleteChangesFor:classNameToDelete
+ from:1
+ to:(changeChunks size).
+ self setChangeList. "/changeListView setContents:changeChunks.
+ self autoSelectOrEnd:changeNr
+ ]
+ ]
]
!
@@ -1127,122 +1272,97 @@
changeNr := changeListView selection.
changeNr notNil ifTrue:[
- self withCursor:(Cursor execute) do:[
- self compareChange:changeNr
- ]
+ self withCursor:(Cursor execute) do:[
+ self compareChange:changeNr
+ ]
]
+! !
+
+!ChangesBrowser methodsFor:'error handling'!
+
+correctableError:aString position:relPos to:relEndPos
+ "compiler notifys us of an error - this should really not happen since
+ changes ought to be correct (did someone edit the changes file ??).
+ Show the bad change in the codeView and let codeView hilight the error;
+ no corrections allowed here therefore return false"
+
+ |action|
+
+ (changeNrProcessed ~~ changeNrShown) ifTrue:[
+ self changeSelection:changeNrProcessed
+ ].
+ (skipSignal notNil) ifTrue:[
+
+ codeView highlightingErrorPosition:relPos to:relEndPos do:[
+ |box|
+
+ "
+ start dialog - make certain cleanup is done
+ "
+ box := OptionBox title:aString numberOfOptions:3.
+ box buttonTitles:#('abort' 'skip' 'continue').
+ box actions:(Array with:[action := #abort]
+ with:[action := #skip]
+ with:[action := #continue]).
+ box showAtPointer
+ ].
+
+ action == #abort ifTrue:[
+ Object abortSignal raise.
+ ^ false
+ ].
+ action == #skip ifTrue:[
+ skipSignal raise.
+ ^ false
+ ].
+ ^ false
+ ].
+ codeView error:aString position:relPos to:relEndPos.
+ ^ false
!
-doCompress
- "compress the change-set; this replaces multiple method-changes by the last
- (i.e. the most recent) change"
+error:aString position:relPos to:relEndPos
+ "compiler notifys us of an error - this should really not happen since
+ changes ought to be correct (did someone edit the changes file ??).
+ Show the bad change in the codeView and let codeView hilight the error"
- |classes types selectors thisClass thisSelector
- aStream chunk changeNr sawExcla aParseTree codeChunk codeParser
- searchIndex anyMore deleteSet index parseTreeChunk numChanges
- excla|
-
- aStream := FileStream readonlyFileNamed:changeFileName.
- aStream isNil ifTrue:[^ self].
+ |action|
- self withCursor:(Cursor execute) do:[
- numChanges := changePositions size.
- classes := Array new:numChanges.
- selectors := Array new:numChanges.
- types := Array new:numChanges.
+ (changeNrProcessed ~~ changeNrShown) ifTrue:[
+ self changeSelection:changeNrProcessed
+ ].
+ (skipSignal notNil) ifTrue:[
- "starting at the end, get the change class and change selector;
- collect all in classes / selectors"
-
- changeNr := numChanges.
- excla := aStream class chunkSeparator.
+ codeView highlightingErrorPosition:relPos to:relEndPos do:[
+ |box|
- [changeNr >= 1] whileTrue:[
- aStream position:(changePositions at:changeNr).
- sawExcla := aStream peekFor:excla.
- chunk := aStream nextChunk.
- sawExcla ifTrue:[
- "optimize a bit if multiple methods for same category arrive"
- (chunk = parseTreeChunk) ifFalse:[
- aParseTree := Parser parseExpression:chunk.
- parseTreeChunk := chunk
- ].
- (aParseTree notNil
- and:[(aParseTree ~~ #Error)
- and:[aParseTree isMessage]]) ifTrue:[
- (aParseTree selector == #methodsFor:) ifTrue:[
- thisClass := (aParseTree receiver evaluate).
- codeChunk := aStream nextChunk.
- codeParser := Parser
- parseMethodSpecification:codeChunk
- in:thisClass
- ignoreErrors:true
- ignoreWarnings:true.
- codeParser notNil ifTrue:[
- selectors at:changeNr put:(codeParser selector).
- classes at:changeNr put:thisClass.
- types at:changeNr put:#methodsFor
- ]
- ]
- ]
- ] ifFalse:[
- aParseTree := Parser parseExpression:chunk.
- parseTreeChunk := chunk.
- (aParseTree notNil
- and:[(aParseTree ~~ #Error)
- and:[aParseTree isMessage]]) ifTrue:[
- (aParseTree selector == #removeSelector:) ifTrue:[
- selectors at:changeNr put:(aParseTree arg1 value ).
- classes at:changeNr put:(aParseTree receiver evaluate).
- types at:changeNr put:#removeSelector
- ]
- ]
- ].
- changeNr := changeNr - 1
- ].
- aStream close.
+ "
+ start dialog - make certain cleanup is done
+ "
+ box := OptionBox title:aString numberOfOptions:3.
+ box buttonTitles:#('abort' 'skip' 'continue').
+ box actions:(Array with:[action := #abort]
+ with:[action := #skip]
+ with:[action := #continue]).
+ box showAtPointer
+ ].
- "for all changes, look for another class/selector occurence and
- add change number to delete set if found"
+ action == #abort ifTrue:[
+ Object abortSignal raise.
+ ^ false
+ ].
+ action == #skip ifTrue:[
+ skipSignal raise.
+ ^ false
+ ].
+ ^ false
+ ].
+ ^ codeView error:aString position:relPos to:relEndPos
+!
- deleteSet := OrderedCollection new.
- changeNr := 1.
- [changeNr < changePositions size] whileTrue:[
- thisClass := classes at:changeNr.
- thisSelector := selectors at:changeNr.
- searchIndex := changeNr.
- anyMore := true.
- [anyMore] whileTrue:[
- searchIndex := classes indexOf:thisClass
- startingAt:(searchIndex + 1).
- (searchIndex ~~ 0) ifTrue:[
- ((selectors at:searchIndex) == thisSelector) ifTrue:[
- thisClass notNil ifTrue:[
- deleteSet add:changeNr.
- anyMore := false
- ]
- ]
- ] ifFalse:[
- anyMore := false
- ]
- ].
- changeNr := changeNr + 1
- ].
+warning:aString position:relPos to:relEndPos
+ "compiler notifys us of a warning - ignore it"
- "finally delete what has been found"
+ ^ self
+! !
- (deleteSet size > 0) ifTrue:[
- changeListView selection:nil.
- index := deleteSet size.
- [index > 0] whileTrue:[
- self silentDeleteChange:(deleteSet at:index).
- index := index - 1
- ].
- self setChangeList.
- changeListView firstLineShown > changeChunks size ifTrue:[
- changeListView makeLineVisible:changeChunks size
- ].
- self clearCodeView
- ]
- ]
-! !
--- a/ChgSetBrwsr.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ChgSetBrwsr.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +13,17 @@
"
ChangesBrowser subclass:#ChangeSetBrowser
- instanceVariableNames:'changeSet originalChangeSet'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'changeSet originalChangeSet'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
ChangeSetBrowser comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.2 1994-08-23 23:48:28 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.3 1994-10-10 03:15:18 claus Exp $
'!
!ChangeSetBrowser class methodsFor:'documentation'!
@@ -31,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.2 1994-08-23 23:48:28 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.3 1994-10-10 03:15:18 claus Exp $
"
!
@@ -59,7 +59,7 @@
openOn:aChangeSet
"create c changes browser on a change set"
- ^ ((self new label:'ChangeSet Browser') changeSet:aChangeSet) realize
+ ^ ((self new label:'ChangeSet Browser') changeSet:aChangeSet) open
! !
!ChangeSetBrowser methodsFor:'initialize / release'!
@@ -68,53 +68,53 @@
|labels|
labels := resources array:#(
- 'apply change'
- 'apply changes to end'
- 'apply all changes'
- '-'
- 'delete'
- 'delete to end'
- 'delete changes for this class to end'
- 'delete all changes for this class'
- '-'
- 'update'
- 'compress'
- 'compare with current version'
- '-'
- 'make change a patch'
- 'update sourcefile from change'
- '-'
- 'saveback changeSet').
+ 'apply change'
+ 'apply changes to end'
+ 'apply all changes'
+ '-'
+ 'delete'
+ 'delete to end'
+ 'delete changes for this class to end'
+ 'delete all changes for this class'
+ '-'
+ 'update'
+ 'compress'
+ 'compare with current version'
+ '-'
+ 'make change a patch'
+ 'update sourcefile from change'
+ '-'
+ 'saveback changeSet').
changeListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(
- doApply
- doApplyRest
- doApplyAll
- nil
- doDelete
- doDeleteRest
- doDeleteClassRest
- doDeleteClassAll
- nil
- doUpdate
- doCompress
- doCompare
- nil
- doMakePatch
- doMakePermanent
- nil
- doSaveBack)
- receiver:self
- for:changeListView)
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ doApply
+ doApplyRest
+ doApplyAll
+ nil
+ doDelete
+ doDeleteRest
+ doDeleteClassRest
+ doDeleteClassAll
+ nil
+ doUpdate
+ doCompress
+ doCompare
+ nil
+ doMakePatch
+ doMakePermanent
+ nil
+ doSaveBack)
+ receiver:self
+ for:changeListView)
! !
!ChangeSetBrowser methodsFor:'private'!
queryCloseText
- ^ 'Quit without updating changeSet ?'
+ ^ 'Quit without updating changeSet ?'
!
streamForChange:changeNr
@@ -131,23 +131,25 @@
originalChangeSet := aChangeSet.
changeSet := OrderedCollection new.
originalChangeSet do:[:aChange |
- changeSet add:aChange
+ changeSet add:aChange
].
!
-readChangesFile
+readChangesFileInBackground:dummy
"read the changeSet, create a list of header-lines"
changeSet size == 0 ifTrue:[^ nil].
self withCursor:(Cursor read) do:[
- changeChunks := VariableArray new.
+ changeChunks := OrderedCollection new.
+ changeHeaderLines := OrderedCollection new.
- changeSet do:[:aChange |
- changeChunks add:(aChange printString)
- ].
- changeClassNames := VariableArray new:(changeChunks size).
- anyChanges := false
+ changeSet do:[:aChange |
+ changeChunks add:(aChange printString).
+ changeHeaderLines add:(aChange printString)
+ ].
+ changeClassNames := OrderedCollection new:(changeChunks size).
+ anyChanges := false
]
!
@@ -155,10 +157,10 @@
"save back the change set"
[originalChangeSet isEmpty] whileFalse:[
- originalChangeSet removeLast
+ originalChangeSet removeLast
].
changeSet do:[:aChange |
- originalChangeSet add:aChange
+ originalChangeSet add:aChange
]
!
@@ -175,7 +177,7 @@
doSaveBack
anyChanges ifTrue:[
- self saveBackChanges.
- self doUpdate
+ self saveBackChanges.
+ self doUpdate
]
! !
--- a/ConInspV.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ConInspV.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +13,17 @@
"
InspectorView subclass:#ContextInspectorView
- instanceVariableNames:'inspectedContext'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:'inspectedContext'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
ContextInspectorView comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/ConInspV.st,v 1.2 1994-08-22 18:07:00 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ConInspV.st,v 1.3 1994-10-10 03:15:23 claus Exp $
'!
!ContextInspectorView class methodsFor:'documentation'!
@@ -31,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/ConInspV.st,v 1.2 1994-08-22 18:07:00 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ConInspV.st,v 1.3 1994-10-10 03:15:23 claus Exp $
"
!
@@ -66,30 +66,36 @@
inspectedObject := nil.
inspectedContext := con.
con isNil ifTrue:[
- inspectedValues := nil.
- listView contents:nil.
- ^ self
+ inspectedValues := nil.
+ listView contents:nil.
+ ^ self
].
homeContext := con methodHome.
+homeContext isNil ifTrue:[
+ "its a cheap blocks context"
+ rec := con receiver.
+ sel := con selector.
+ names := OrderedCollection new.
+] ifFalse:[
rec := homeContext receiver.
sel := homeContext selector.
implementorClass := homeContext searchClass whichClassImplements:sel.
implementorClass notNil ifTrue:[
- method := implementorClass compiledMethodAt:sel.
- names := method methodArgAndVarNames
+ method := implementorClass compiledMethodAt:sel.
+ names := method methodArgAndVarNames
].
-
+].
"create dummy names (if there is no source available)"
names isNil ifTrue:[
- names := OrderedCollection new.
- 1 to:homeContext nargs do:[:index |
- names add:('mArg' , index printString)
- ].
- 1 to:homeContext nvars do:[:index |
- names add:('mVar' , index printString)
- ].
+ names := OrderedCollection new.
+ 1 to:homeContext numArgs do:[:index |
+ names add:('mArg' , index printString)
+ ].
+ 1 to:homeContext nvars do:[:index |
+ names add:('mVar' , index printString)
+ ].
].
aList := OrderedCollection new.
@@ -99,15 +105,19 @@
method-home and put real names in here
"
con isBlockContext ifTrue:[
- argNames := (1 to:(con nargs)) collect:[:i | 'arg' , i printString].
- aList addAll:argNames.
- varNames := (1 to:(con nvars)) collect:[:i | 'var' , i printString].
- aList addAll:varNames.
- aList addAll:names.
- inspectedValues := (Array withAll:(con argsAndVars)) , homeContext argsAndVars
+ argNames := (1 to:(con numArgs)) collect:[:i | 'arg' , i printString].
+ aList addAll:argNames.
+ varNames := (1 to:(con nvars)) collect:[:i | 'var' , i printString].
+ aList addAll:varNames.
+ aList addAll:names.
+ homeContext isNil ifTrue:[
+ inspectedValues := Array withAll:(con argsAndVars)
+ ] ifFalse:[
+ inspectedValues := (Array withAll:(con argsAndVars)) , homeContext argsAndVars
+ ]
] ifFalse:[
- aList addAll:names.
- inspectedValues := homeContext argsAndVars
+ aList addAll:names.
+ inspectedValues := homeContext argsAndVars
].
listView contents:aList.
@@ -126,12 +136,12 @@
setDoitActionIn:aWorkspace for:aContext
aWorkspace doItAction:[:theCode |
- Compiler evaluate:theCode
- in:aContext
- receiver:nil
- notifying:aWorkspace
- logged:true
- ifFail:nil
+ Compiler evaluate:theCode
+ in:aContext
+ receiver:nil
+ notifying:aWorkspace
+ logged:true
+ ifFail:nil
]
! !
@@ -141,11 +151,11 @@
|value|
selectedLine notNil ifTrue:[
- value := Compiler evaluate:theText
- receiver:inspectedObject
- notifying:workspace.
+ value := Compiler evaluate:theText
+ receiver:inspectedObject
+ notifying:workspace.
- "yes, you can do that with a context"
- inspectedContext at:selectedLine put:value.
+ "yes, you can do that with a context"
+ inspectedContext at:selectedLine put:value.
].
! !
--- a/ContextInspectorView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ContextInspectorView.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +13,17 @@
"
InspectorView subclass:#ContextInspectorView
- instanceVariableNames:'inspectedContext'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:'inspectedContext'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
ContextInspectorView comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/ContextInspectorView.st,v 1.2 1994-08-22 18:07:00 claus Exp $
+$Header: /cvs/stx/stx/libtool/ContextInspectorView.st,v 1.3 1994-10-10 03:15:23 claus Exp $
'!
!ContextInspectorView class methodsFor:'documentation'!
@@ -31,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/ContextInspectorView.st,v 1.2 1994-08-22 18:07:00 claus Exp $
+$Header: /cvs/stx/stx/libtool/ContextInspectorView.st,v 1.3 1994-10-10 03:15:23 claus Exp $
"
!
@@ -66,30 +66,36 @@
inspectedObject := nil.
inspectedContext := con.
con isNil ifTrue:[
- inspectedValues := nil.
- listView contents:nil.
- ^ self
+ inspectedValues := nil.
+ listView contents:nil.
+ ^ self
].
homeContext := con methodHome.
+homeContext isNil ifTrue:[
+ "its a cheap blocks context"
+ rec := con receiver.
+ sel := con selector.
+ names := OrderedCollection new.
+] ifFalse:[
rec := homeContext receiver.
sel := homeContext selector.
implementorClass := homeContext searchClass whichClassImplements:sel.
implementorClass notNil ifTrue:[
- method := implementorClass compiledMethodAt:sel.
- names := method methodArgAndVarNames
+ method := implementorClass compiledMethodAt:sel.
+ names := method methodArgAndVarNames
].
-
+].
"create dummy names (if there is no source available)"
names isNil ifTrue:[
- names := OrderedCollection new.
- 1 to:homeContext nargs do:[:index |
- names add:('mArg' , index printString)
- ].
- 1 to:homeContext nvars do:[:index |
- names add:('mVar' , index printString)
- ].
+ names := OrderedCollection new.
+ 1 to:homeContext numArgs do:[:index |
+ names add:('mArg' , index printString)
+ ].
+ 1 to:homeContext nvars do:[:index |
+ names add:('mVar' , index printString)
+ ].
].
aList := OrderedCollection new.
@@ -99,15 +105,19 @@
method-home and put real names in here
"
con isBlockContext ifTrue:[
- argNames := (1 to:(con nargs)) collect:[:i | 'arg' , i printString].
- aList addAll:argNames.
- varNames := (1 to:(con nvars)) collect:[:i | 'var' , i printString].
- aList addAll:varNames.
- aList addAll:names.
- inspectedValues := (Array withAll:(con argsAndVars)) , homeContext argsAndVars
+ argNames := (1 to:(con numArgs)) collect:[:i | 'arg' , i printString].
+ aList addAll:argNames.
+ varNames := (1 to:(con nvars)) collect:[:i | 'var' , i printString].
+ aList addAll:varNames.
+ aList addAll:names.
+ homeContext isNil ifTrue:[
+ inspectedValues := Array withAll:(con argsAndVars)
+ ] ifFalse:[
+ inspectedValues := (Array withAll:(con argsAndVars)) , homeContext argsAndVars
+ ]
] ifFalse:[
- aList addAll:names.
- inspectedValues := homeContext argsAndVars
+ aList addAll:names.
+ inspectedValues := homeContext argsAndVars
].
listView contents:aList.
@@ -126,12 +136,12 @@
setDoitActionIn:aWorkspace for:aContext
aWorkspace doItAction:[:theCode |
- Compiler evaluate:theCode
- in:aContext
- receiver:nil
- notifying:aWorkspace
- logged:true
- ifFail:nil
+ Compiler evaluate:theCode
+ in:aContext
+ receiver:nil
+ notifying:aWorkspace
+ logged:true
+ ifFail:nil
]
! !
@@ -141,11 +151,11 @@
|value|
selectedLine notNil ifTrue:[
- value := Compiler evaluate:theText
- receiver:inspectedObject
- notifying:workspace.
+ value := Compiler evaluate:theText
+ receiver:inspectedObject
+ notifying:workspace.
- "yes, you can do that with a context"
- inspectedContext at:selectedLine put:value.
+ "yes, you can do that with a context"
+ inspectedContext at:selectedLine put:value.
].
! !
--- a/DebugView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/DebugView.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -12,15 +12,16 @@
StandardSystemView subclass:#DebugView
instanceVariableNames:'busy haveControl exitAction canContinue
- contextView codeView
- receiverInspector contextInspector
- contextArray selectedContext
- catchBlock grabber traceView tracing
- bigStep steppedContextAddress canAbort
- abortButton terminateButton continueButton
- stepButton sendButton returnButton restartButton
- exclusive inspecting nChainShown
- processList'
+ contextView codeView
+ receiverInspector contextInspector
+ contextArray selectedContext
+ catchBlock grabber traceView tracing
+ bigStep steppedContextAddress canAbort
+ abortButton terminateButton continueButton
+ stepButton sendButton returnButton restartButton
+ exclusive inspecting nChainShown
+ inspectedProcess updateProcess
+ monitorToggle'
classVariableNames:'CachedDebugger CachedExclusive'
poolDictionaries:''
category:'Interface-Debugger'
@@ -28,9 +29,9 @@
DebugView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.13 1994-08-22 18:07:04 claus Exp $
+$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.14 1994-10-10 03:15:25 claus Exp $
'!
!DebugView class methodsFor:'documentation'!
@@ -38,7 +39,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -51,7 +52,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.13 1994-08-22 18:07:04 claus Exp $
+$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.14 1994-10-10 03:15:25 claus Exp $
"
!
@@ -92,21 +93,21 @@
(ProcessorScheduler isPureEventDriven
or:[(active priority > Processor userSchedulingPriority)
or:[active nameOrId endsWith:'dispatcher']]) ifTrue:[
- CachedExclusive isNil ifTrue:[
- debugger := self newExclusive
- ] ifFalse:[
- debugger := CachedExclusive.
- CachedExclusive := nil.
- ].
+ CachedExclusive isNil ifTrue:[
+ debugger := self newExclusive
+ ] ifFalse:[
+ debugger := CachedExclusive.
+ CachedExclusive := nil.
+ ].
] ifFalse:[
- CachedDebugger isNil ifTrue:[
- debugger := super new.
- debugger label:'Debugger'.
- debugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
- ] ifFalse:[
- debugger := CachedDebugger.
- CachedDebugger := nil.
- ]
+ CachedDebugger isNil ifTrue:[
+ debugger := super new.
+ debugger label:'Debugger'.
+ debugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
+ ] ifFalse:[
+ debugger := CachedDebugger.
+ CachedDebugger := nil.
+ ]
].
^ debugger
!
@@ -137,7 +138,7 @@
error- and halt messages"
thisContext isRecursive ifTrue:[
- ^ MiniDebugger enterWithMessage:aString
+ ^ MiniDebugger enterWithMessage:aString
].
^ self enter:(thisContext sender) withMessage:aString
@@ -165,7 +166,7 @@
|aDebugger|
thisContext isRecursive ifTrue:[
- ^ MiniDebugger enterWithMessage:'recursive error'.
+ ^ MiniDebugger enterWithMessage:'recursive error'.
].
StepInterruptPending := nil.
@@ -186,9 +187,9 @@
aDebugger := super new.
aDebugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
aProcess notNil ifTrue:[
- label := 'inspecting Debugger (' , aProcess nameOrId , ')'.
+ label := 'process Debugger (' , aProcess nameOrId , ')'.
] ifFalse:[
- label := 'no process'
+ label := 'no process'
].
aDebugger label:label.
aDebugger iconLabel:'Debugger'.
@@ -199,7 +200,7 @@
!DebugView methodsFor:'initialization'!
initialize
- |v panel hpanel bpanel|
+ |v panel hpanel bpanel dummy|
super initialize.
@@ -214,46 +215,52 @@
canAbort := false.
bpanel := HorizontalPanelView
- origin:(0.0 @ 0.0)
- extent:(1.0 @ (font height * 2))
- in:self.
+ origin:(0.0 @ 0.0)
+ extent:(1.0 @ (font height * 2))
+ in:self.
bpanel layout:#left.
terminateButton := Button
- label:(resources at:'terminate')
- action:[terminateButton turnOffWithoutRedraw. self doTerminate]
- in:bpanel.
+ label:(resources at:'terminate')
+ action:[terminateButton turnOffWithoutRedraw. self doTerminate]
+ in:bpanel.
+ dummy := View extent:(20 @ 5) in:bpanel.
+
abortButton := Button
- label:(resources at:'abort')
- action:[abortButton turnOffWithoutRedraw. self doAbort]
- in:bpanel.
+ label:(resources at:'abort')
+ action:[abortButton turnOffWithoutRedraw. self doAbort]
+ in:bpanel.
returnButton := Button
- label:(resources at:'return')
- action:[returnButton turnOff. self doReturn]
- in:bpanel.
+ label:(resources at:'return')
+ action:[returnButton turnOff. self doReturn]
+ in:bpanel.
restartButton := Button
- label:(resources at:'restart')
- action:[restartButton turnOff. self doRestart]
- in:bpanel.
+ label:(resources at:'restart')
+ action:[restartButton turnOff. self doRestart]
+ in:bpanel.
+
+ dummy := View extent:(20 @ 5) in:bpanel.
continueButton := Button
- label:(resources at:'continue')
- action:[continueButton turnOffWithoutRedraw. self doContinue]
- in:bpanel.
+ label:(resources at:'continue')
+ action:[continueButton turnOffWithoutRedraw. self doContinue]
+ in:bpanel.
+ dummy := View extent:(20 @ 5) in:bpanel.
+
stepButton := Button
- label:(resources at:'step')
- action:[stepButton turnOff. self doStep]
- in:bpanel.
+ label:(resources at:'step')
+ action:[stepButton turnOff. self doStep]
+ in:bpanel.
sendButton := Button
- label:(resources at:'send')
- action:[sendButton turnOff. self doSend]
- in:bpanel.
+ label:(resources at:'send')
+ action:[sendButton turnOff. self doSend]
+ in:bpanel.
panel := VariableVerticalPanel
- origin:(0.0 @ bpanel height)
- corner:(1.0 @ 1.0)
- in:self.
+ origin:(0.0 @ bpanel height)
+ corner:(1.0 @ 1.0)
+ in:self.
v := ScrollableView for:SelectionInListView in:panel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
@@ -270,71 +277,83 @@
hpanel origin:(0.0 @ 0.75) corner:(1.0 @ 1.0).
receiverInspector := InspectorView
- origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)
- in:hpanel.
+ origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)
+ in:hpanel.
contextInspector := ContextInspectorView
- origin:(0.5 @ 0.0) corner:(1.0 @ 1.0)
- in:hpanel
+ origin:(0.5 @ 0.0) corner:(1.0 @ 1.0)
+ in:hpanel
!
initializeMiddleButtonMenu
- |labels|
+ |labels m|
labels := resources array:#(
- 'show more'
- '-'
+ 'show more'
+ '-'
"
- 'continue'
- 'terminate'
- 'abort'
- '-'
- 'step'
- 'send'
- '-'
- 'return'
- 'restart'
- '-'
+ 'continue'
+ 'terminate'
+ 'abort'
+ '-'
+ 'step'
+ 'send'
+ '-'
+ 'return'
+ 'restart'
+ '-'
"
- 'remove breakpoint'
- '-'
- 'implementors ...'
- 'senders ...'
- '-'
- 'inspect context'
- '-'
- 'exit smalltalk'
- ).
+ 'remove breakpoint'
+ '-'
+ 'implementors ...'
+ 'senders ...'
+ '-'
+ 'inspect context'
+ '-'
+ 'quickTerminate'
+ '-'
+ 'exit smalltalk'
+ ).
- contextView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(
- doShowMore
- nil
+ m := (PopUpMenu
+ labels:labels
+ selectors:#(
+ doShowMore
+ nil
+"
+ doContinue
+ doTerminate
+ doAbort
+ nil
+ doStep
+ doSend
+ nil
+ doReturn
+ doRestart
+ nil
"
- doContinue
- doTerminate
- doAbort
- nil
- doStep
- doSend
- nil
- doReturn
- doRestart
- nil
-"
- doRemoveBreakpoint
- nil
- doImplementors
- doSenders
- nil
- doInspectContext
- nil
- doExit
- )
- receiver:self
- for:contextView).
+ doRemoveBreakpoint
+ nil
+ doImplementors
+ doSenders
+ nil
+ doInspectContext
+ nil
+ doQuickTerminate
+ nil
+ doExit
+ )
+ receiver:self
+ for:contextView).
+
+ contextView middleButtonMenu:m.
+
+ inspecting ifTrue:[
+ m notNil ifTrue:[
+ m disable:#doTraceStep.
+ m disable:#doRemoveBreakpoint.
+ ].
+ ]
!
addToCurrentProject
@@ -350,8 +369,13 @@
realize
super realize.
exclusive ifTrue:[
- windowGroup := nil
+ windowGroup := nil
].
+
+ inspectedProcess notNil ifTrue:[
+ Processor activeProcess
+ priority:(inspectedProcess priority + 2 min:16).
+ ]
! !
!DebugView methodsFor:'interrupt handling'!
@@ -373,108 +397,108 @@
wrappedMethod := nil.
5 timesRepeat:[
"/ where selector printNL.
- method := where method.
- (method notNil and:[method isWrapped]) ifTrue:[
- "
- in a wrapper method
- "
- wrappedMethod ~~ method ifTrue:[
- wrappedMethod := method.
- lastWrappedConAddr := ObjectMemory addressOf:where.
- where sender receiver == method originalMethod ifFalse:[
- isWrap := true.
- ]
- ] ifFalse:[
- (ObjectMemory addressOf:where) == steppedContextAddress ifTrue:[
+ method := where method.
+ (method notNil and:[method isWrapped]) ifTrue:[
+ "
+ in a wrapper method
+ "
+ wrappedMethod ~~ method ifTrue:[
+ wrappedMethod := method.
+ lastWrappedConAddr := ObjectMemory addressOf:where.
+ where sender receiver == method originalMethod ifFalse:[
+ isWrap := true.
+ ]
+ ] ifFalse:[
+ (ObjectMemory addressOf:where) == steppedContextAddress ifTrue:[
"/ 'change stepCon from: ' print.
"/ (steppedContextAddress printStringRadix:16)print.
"/ ' to: ' print.
"/ (lastWrappedConAddr printStringRadix:16)printNL.
- steppedContextAddress := lastWrappedConAddr
- ]
- ]
- ].
- where := where sender
+ steppedContextAddress := lastWrappedConAddr
+ ]
+ ]
+ ].
+ where := where sender
].
isWrap ifTrue:[
"/ 'ignore wrap' printNL.
- "
- ignore, while in wrappers hidden setup
- "
- where := nil. here := nil.
- ObjectMemory flushInlineCaches.
- StepInterruptPending := true.
- InterruptPending := true.
- InStepInterrupt := nil.
- ^ nil
+ "
+ ignore, while in wrappers hidden setup
+ "
+ where := nil. here := nil.
+ ObjectMemory flushInlineCaches.
+ StepInterruptPending := true.
+ InterruptPending := true.
+ InStepInterrupt := nil.
+ ^ nil
].
"
is this for a send or a step ?
"
bigStep ifTrue:[
- "
- a step - ignore all contexts below the interresting one
- "
- where := here. "the interrupted context"
- (ObjectMemory addressOf:where) == steppedContextAddress ifFalse:[
- where := where sender.
+ "
+ a step - ignore all contexts below the interresting one
+ "
+ where := here. "the interrupted context"
+ (ObjectMemory addressOf:where) == steppedContextAddress ifFalse:[
+ where := where sender.
"/ 'look for ' print.
"/ (steppedContextAddress printStringRadix:16)print. '' printNL.
- (ObjectMemory addressOf:where) == steppedContextAddress ifFalse:[
- "
- check if we are in a context below steppedContext
- (i.e. if steppedContext can be reached from
- interrupted context. Not using context-ref but its
- address to avoid creation of many useless contexts.)
- "
- [where notNil] whileTrue:[
+ (ObjectMemory addressOf:where) == steppedContextAddress ifFalse:[
+ "
+ check if we are in a context below steppedContext
+ (i.e. if steppedContext can be reached from
+ interrupted context. Not using context-ref but its
+ address to avoid creation of many useless contexts.)
+ "
+ [where notNil] whileTrue:[
"/ ((ObjectMemory addressOf:where) printStringRadix:16)print. ' ' print.
"/ where selector printNL.
- (ObjectMemory addressOf:where) == steppedContextAddress ifTrue:[
+ (ObjectMemory addressOf:where) == steppedContextAddress ifTrue:[
"/ 'found it - below' printNL.
- "
- found the interresting context somwehere up in the
- chain. We seem to be still below the interresting one ...
- "
- tracing == true ifTrue:[
- here printString printNewline
- ].
- where := nil. here := nil.
- "
- yes, a context below
- - continue and schedule another stepInterrupt.
- Must flush caches since optimized methods not always
- look for pending interrupts
- "
- ObjectMemory flushInlineCaches.
- StepInterruptPending := true.
- InterruptPending := true.
- InStepInterrupt := nil.
- ^ nil
- ].
- where := where sender
- ].
- s := 'left stepped method'
- ] ifTrue:[
+ "
+ found the interresting context somwehere up in the
+ chain. We seem to be still below the interresting one ...
+ "
+ tracing == true ifTrue:[
+ here printString printNewline
+ ].
+ where := nil. here := nil.
+ "
+ yes, a context below
+ - continue and schedule another stepInterrupt.
+ Must flush caches since optimized methods not always
+ look for pending interrupts
+ "
+ ObjectMemory flushInlineCaches.
+ StepInterruptPending := true.
+ InterruptPending := true.
+ InStepInterrupt := nil.
+ ^ nil
+ ].
+ where := where sender
+ ].
+ s := 'left stepped method'
+ ] ifTrue:[
"/ 'found it right in sender' printNL.
- s := 'after step'
- ].
- ] ifTrue:[
+ s := 'after step'
+ ].
+ ] ifTrue:[
"/ 'found it right away' printNL.
- s := 'after step'
- ].
- tracing := false.
- bigStep := false.
+ s := 'after step'
+ ].
+ tracing := false.
+ bigStep := false.
] ifFalse:[
- "
- a send
- "
- steppedContextAddress := nil.
- s := 'after send'
+ "
+ a send
+ "
+ steppedContextAddress := nil.
+ s := 'after send'
].
name := Processor activeProcess nameOrId.
@@ -497,10 +521,10 @@
where := thisContext. "enter"
where := where sender. "the calling context"
where notNil ifTrue:[
- (where receiver == DebugView) ifTrue:[
- where := where sender
- ]
- "where is now interrupted methods context"
+ (where receiver == DebugView) ifTrue:[
+ where := where sender
+ ]
+ "where is now interrupted methods context"
].
^ self enter:where
!
@@ -509,10 +533,11 @@
"enter the debugger - get and display the context, then start an
exclusive event loop on top of eveything else"
- |con selection|
+ |con selection m|
busy := true.
inspecting := false.
+ inspectedProcess := nil.
bigStep := false.
nChainShown := 50.
@@ -521,31 +546,33 @@
us here
"
ActiveGrab notNil ifTrue:[
- grabber := ActiveGrab.
- ActiveGrab device ungrabPointer.
- ActiveGrab device synchronizeOutput.
- ActiveGrab := nil
+ grabber := ActiveGrab.
+ ActiveGrab device ungrabPointer.
+ ActiveGrab device synchronizeOutput.
+ ActiveGrab := nil
] ifFalse:[
- grabber := nil
+ grabber := nil
].
+ terminateButton enable.
+
drawableId notNil ifTrue:[
- "not the first time - realize at old position"
- terminateButton turnOffWithoutRedraw.
- continueButton turnOffWithoutRedraw.
- abortButton turnOffWithoutRedraw.
- stepButton turnOffWithoutRedraw.
- sendButton turnOffWithoutRedraw.
- self rerealize
+ "not the first time - realize at old position"
+ terminateButton turnOffWithoutRedraw.
+ continueButton turnOffWithoutRedraw.
+ abortButton turnOffWithoutRedraw.
+ stepButton turnOffWithoutRedraw.
+ sendButton turnOffWithoutRedraw.
+ self rerealize
] ifFalse:[
- exclusive ifFalse:[
- windowGroup isNil ifTrue:[
- windowGroup := WindowGroup new.
- windowGroup addTopView:self.
- ].
- ].
- self realize.
- self iconLabel:'Debugger'.
+ exclusive ifFalse:[
+ windowGroup isNil ifTrue:[
+ windowGroup := WindowGroup new.
+ windowGroup addTopView:self.
+ ].
+ ].
+ self realize.
+ self iconLabel:'Debugger'.
].
"
@@ -563,44 +590,47 @@
and find one to show
"
steppedContextAddress isNil ifTrue:[
- "
- preselect a more interresting context, (where halt/raise was ...)
- "
- selection := self interrestingContextFrom:aContext.
+ "
+ preselect a more interresting context, (where halt/raise was ...)
+ "
+ selection := self interrestingContextFrom:aContext.
] ifFalse:[
- "
- if we came here by a big-step, show the method where we are
- "
- steppedContextAddress notNil ifTrue:[
- (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
- selection := 1
- ] ifFalse:[
- (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
- selection := 2
- ]
- ]
- ]
+ "
+ if we came here by a big-step, show the method where we are
+ "
+ steppedContextAddress notNil ifTrue:[
+ (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
+ selection := 1
+ ] ifFalse:[
+ (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
+ selection := 2
+ ]
+ ]
+ ]
].
selection notNil ifTrue:[
- self showSelection:selection.
- contextView selection:selection
+ self showSelection:selection.
+ contextView selection:selection
].
- canAbort := Object abortSignal isHandled.
- canAbort ifTrue:[
- abortButton enable.
- contextView middleButtonMenu enable:#doAbort.
- ] ifFalse:[
- abortButton disable.
- contextView middleButtonMenu disable:#doAbort.
- ].
- exclusive ifTrue:[
- terminateButton disable.
- contextView middleButtonMenu disable:#doTerminate.
- ] ifFalse:[
- terminateButton enable.
- contextView middleButtonMenu enable:#doTerminate.
+ m := contextView middleButtonMenu.
+ m notNil ifTrue:[
+ canAbort := inspecting or:[Object abortSignal isHandled].
+ canAbort ifTrue:[
+ abortButton enable.
+ m enable:#doAbort.
+ ] ifFalse:[
+ abortButton disable.
+ m disable:#doAbort.
+ ].
+ exclusive ifTrue:[
+ terminateButton disable.
+ m disable:#doTerminate.
+ ] ifFalse:[
+ terminateButton enable.
+ m enable:#doTerminate.
+ ]
].
"
@@ -614,70 +644,110 @@
contextInspector release.
(exitAction == #step) ifFalse:[
- self unrealize.
- device synchronizeOutput.
- (exitAction == #abort) ifTrue:[
- selectedContext := nil.
- InInterrupt := nil.
- busy := false.
- exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
- Object abortSignal raise.
- 'abort failed' errorPrintNewline
- ].
- (exitAction == #return) ifTrue:[
- selectedContext notNil ifTrue:[
- con := selectedContext.
- selectedContext := nil.
- InInterrupt := nil.
- busy := false.
- exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
- con unwind.
- 'cannot return selected context' errorPrintNewline
- ]
- ] ifFalse:[
- (exitAction == #restart) ifTrue:[
- selectedContext notNil ifTrue:[
- con := selectedContext.
- selectedContext := nil.
- InInterrupt := nil.
- busy := false.
- exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
- con restart.
- 'cannot restart selected context' errorPrintNewline
- ]
- ] ifFalse:[
- (exitAction == #terminate) ifTrue:[
- selectedContext := nil.
- InInterrupt := nil.
- busy := false.
- exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
- Processor activeProcess terminate.
- 'cannot terminate process' errorPrintNewline
- ]
- ]
- ]
+ self unrealize.
+ device synchronizeOutput.
+ (exitAction == #abort) ifTrue:[
+ selectedContext := nil.
+ InInterrupt := nil.
+ busy := false.
+ exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ Object abortSignal raise.
+ ].
+ 'abort failed' errorPrintNewline
+ ].
+ (exitAction == #return) ifTrue:[
+ selectedContext notNil ifTrue:[
+ con := selectedContext.
+ selectedContext := nil.
+ InInterrupt := nil.
+ busy := false.
+ exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ con unwind.
+ ].
+ 'cannot return selected context' errorPrintNewline
+ ]
+ ] ifFalse:[
+ (exitAction == #restart) ifTrue:[
+ selectedContext notNil ifTrue:[
+ con := selectedContext.
+ selectedContext := nil.
+ InInterrupt := nil.
+ busy := false.
+ exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ con restart.
+ ].
+ 'cannot restart selected context' errorPrintNewline
+ ]
+ ] ifFalse:[
+ ((exitAction == #terminate) or:[exitAction == #quickTerminate]) ifTrue:[
+ selectedContext := nil.
+ InInterrupt := nil.
+ busy := false.
+ exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self].
+ exitAction == #quickTerminate ifTrue:[
+ Processor activeProcess terminateNoSignal
+ ] ifFalse:[
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ Processor activeProcess terminate.
+ ].
+ ].
+ 'cannot terminate process' errorPrintNewline
+ ]
+ ]
+ ]
].
selectedContext := nil.
grabber notNil ifTrue:[
- grabber device grabPointerIn:(grabber id).
- ActiveGrab := grabber
+ grabber device grabPointerIn:(grabber id).
+ ActiveGrab := grabber
].
(exitAction == #step) ifTrue:[
- "scedule another stepInterrupt
- - must flush caches since optimized methods not always
- look for pending interrupts"
- ObjectMemory flushInlineCaches.
+ "scedule another stepInterrupt
+ - must flush caches since optimized methods not always
+ look for pending interrupts"
+ ObjectMemory flushInlineCaches.
- ObjectMemory stepInterruptHandler:self.
- StepInterruptPending := true.
- InterruptPending := true.
- InStepInterrupt := nil
+ ObjectMemory stepInterruptHandler:self.
+ StepInterruptPending := true.
+ InterruptPending := true.
+ InStepInterrupt := nil
] ifFalse:[
- busy := false.
- exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self]
+ busy := false.
+ exclusive ifTrue:[CachedExclusive := self] ifFalse:[CachedDebugger := self]
]
!
@@ -688,53 +758,71 @@
Also, we do not run on top of the debugger process, but as a separate
one. (think of it as an inspector showing more detail)"
+ |bpanel updateButton stopButton dummy|
+
busy := true.
bigStep := false.
inspecting := true.
+ inspectedProcess := aProcess.
nChainShown := 50.
+ bpanel := abortButton superView.
+
+ stopButton := Button new.
+ stopButton label:(resources at:'stop');
+ action:[self doStop].
+ bpanel addSubView:stopButton after:continueButton.
+
+ dummy := View extent:(20 @ 5) in:bpanel.
+
+"/ stepButton destroy.
+"/ sendButton destroy.
+
+ updateButton := Button
+ label:(resources at:'update')
+ action:[self updateContext]
+ in:bpanel.
+ monitorToggle := Toggle in:bpanel.
+ monitorToggle label:(resources at:'monitor').
+ monitorToggle pressAction:[self autoUpdateOn].
+ monitorToggle releaseAction:[self autoUpdateOff].
+
"can only look into process - context chain is not active"
canContinue := true.
- abortButton disable.
+ terminateButton enable.
+ abortButton enable.
+
sendButton disable.
stepButton disable.
- continueButton disable.
- returnButton disable.
- restartButton disable.
-
- self initializeMiddleButtonMenu.
- contextView middleButtonMenu disable:#doAbort.
- contextView middleButtonMenu disable:#doSend.
- contextView middleButtonMenu disable:#doStep.
- contextView middleButtonMenu disable:#doContinue.
- contextView middleButtonMenu disable:#doReturn.
- contextView middleButtonMenu disable:#doRestart.
- contextView middleButtonMenu disable:#doTraceStep.
- contextView middleButtonMenu disable:#doTerminate.
- contextView middleButtonMenu disable:#doRemoveBreakpoint.
- contextView middleButtonMenu disable:#doImplementors.
- contextView middleButtonMenu disable:#doSenders.
- contextView middleButtonMenu disable:#doInspectContext.
+"/ continueButton disable.
+"/ returnButton disable.
+"/ restartButton disable.
aProcess isNil ifTrue:[
- terminateButton disable.
+ terminateButton disable.
+ abortButton disable.
+ continueButton disable.
+ returnButton disable.
+ restartButton disable.
] ifFalse:[
- aProcess suspendedContext isNil ifTrue:[
- terminateButton disable.
- contextView middleButtonMenu disable:#doTerminate.
- ].
+ aProcess suspendedContext isNil ifTrue:[
+ terminateButton disable.
+ ].
- self setContext:aProcess suspendedContext.
+ self setContext:aProcess suspendedContext.
- catchBlock := [
- contextArray := nil.
- selectedContext := nil.
- (exitAction == #terminate) ifTrue:[
- aProcess terminate.
- ].
- super destroy
- ].
+ catchBlock := [
+ contextArray := nil.
+ selectedContext := nil.
+ (exitAction == #terminate) ifTrue:[
+ aProcess terminate.
+ ].
+ (exitAction == #quickTerminate) ifTrue:[
+ aProcess terminateNoSignal.
+ ].
+ super destroy
+ ].
].
self open
! !
@@ -743,13 +831,13 @@
controlLoop
"this is a kludge:
- start a dispatchloop which exits when
- either continue, return or step is pressed
+ start a dispatchloop which exits when
+ either continue, return or step is pressed
"
haveControl := true.
[haveControl] whileTrue:[
- self controlLoopCatchingErrors
+ self controlLoopCatchingErrors
].
catchBlock := nil.
@@ -765,26 +853,27 @@
catchBlock := [^ nil].
exclusive ifTrue:[
- "if we do not have multiple processes or its a system process
- we start another dispatch loop, which exits when
- either continue, return or step is pressed
- or (via the catchBlock) if an error occurs.
- Since our display is an extra exclusive one (ModalDisplay)
- all processing for normal views stops here ...
- "
- device dispatchModalWhile:[haveControl]
+ "if we do not have multiple processes or its a system process
+ we start another dispatch loop, which exits when
+ either continue, return or step is pressed
+ or (via the catchBlock) if an error occurs.
+ Since our display is an extra exclusive one (ModalDisplay)
+ all processing for normal views stops here ...
+ "
+ device dispatchModalWhile:[haveControl]
] ifFalse:[
- "we do have multiple processes -
- simply enter the DebugViews-Windowgroup event loop.
- effectively suspending event processing for the currently
- active group.
- "
- SignalSet anySignal handle:[:ex |
- 'error within debugger ignored' errorPrintNewline.
- ex return.
- ] do:[
- windowGroup eventLoopWhile:[true]
- ]
+ "we do have multiple processes -
+ simply enter the DebugViews-Windowgroup event loop.
+ effectively suspending event processing for the currently
+ active group.
+ "
+ SignalSet anySignal handle:[:ex |
+ 'ignored error in debugger: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex return.
+ ] do:[
+ windowGroup eventLoopWhile:[true]
+ ]
]
! !
@@ -808,16 +897,16 @@
c := aContext.
1 to:5 do:[:i |
- c isNil ifTrue:[^ 1 "^ nil"].
- sel := c selector.
- ((sel == #raise)
- or:[(sel == #raiseRequestWith:)
- or:[(sel == #raiseRequestWith:errorString:)]])
- ifTrue:[
- offset := i.
- found := c
- ].
- c := c sender.
+ c isNil ifTrue:[^ 1 "^ nil"].
+ sel := c selector.
+ ((sel == #raise)
+ or:[(sel == #raiseRequestWith:)
+ or:[(sel == #raiseRequestWith:errorString:)]])
+ ifTrue:[
+ offset := i.
+ found := c
+ ].
+ c := c sender.
].
(c := found) isNil ifTrue:[^ 1 "nil"].
@@ -836,31 +925,31 @@
if raise implementation reuses raise code ...
"
[
- #( raise raiseRequestWith: #raiseRequestWith:errorString: )
- includes:c selector
+ #( raise raiseRequestWith: #raiseRequestWith:errorString: )
+ includes:c selector
] whileTrue:[
- (c := c sender) isNil ifTrue:[^ offset].
- offset := offset + 1.
+ (c := c sender) isNil ifTrue:[^ offset].
+ offset := offset + 1.
].
"
if the sender of the raise is one of objects error methods ...
"
( #( halt halt:
- error error:
- doesNotUnderstand:
- subclassResponsibility
- primitiveFailed) includes:c selector)
+ error error:
+ doesNotUnderstand:
+ subclassResponsibility
+ primitiveFailed) includes:c selector)
ifTrue:[
- c selector == #doesNotUnderstand: ifTrue:[
- "
- one more up, to get to the originating context
- "
- (c := c sender) isNil ifTrue:[^ offset].
- offset := offset + 1.
- ].
- (c := c sender) isNil ifTrue:[^ offset].
- offset := offset + 1.
+ c selector == #doesNotUnderstand: ifTrue:[
+ "
+ one more up, to get to the originating context
+ "
+ (c := c sender) isNil ifTrue:[^ offset].
+ offset := offset + 1.
+ ].
+ (c := c sender) isNil ifTrue:[^ offset].
+ offset := offset + 1.
].
^ offset
@@ -869,67 +958,96 @@
setContext:aContext
"show calling chain from aContext in the walk-back listview"
- |con text method caller caller2|
+ |con text method caller caller2 m|
+
+ m := contextView middleButtonMenu.
+ m notNil ifTrue:[
+ m disable:#doShowMore.
+ ].
aContext isNil ifTrue:[
- text := Array with:'** no context **'.
- contextArray := nil.
- contextView middleButtonMenu disable:#doShowMore.
+ text := Array with:'** no context **'.
+ contextArray := nil.
] ifFalse:[
- text := OrderedCollection new:nChainShown.
- contextArray := OrderedCollection new:nChainShown.
- con := aContext.
+ text := OrderedCollection new:nChainShown.
+ contextArray := OrderedCollection new:nChainShown.
+ con := aContext.
- "
- get them all
- "
- [con notNil and:[contextArray size <= nChainShown]] whileTrue:[
- contextArray add:con.
- text add:(con printString).
+ "
+ get them all
+ "
+ [con notNil and:[contextArray size <= nChainShown]] whileTrue:[
+ contextArray add:con.
+ (Smalltalk at:#SystemDebugging ifAbsent:[false]) ifTrue:[
+ text add:(((ObjectMemory addressOf:con) printStringRadix:16) , ' ' , con printString).
+ ] ifFalse:[
+ text add:con printString.
+ ].
- method := con method.
- (method notNil and:[method isWrapped]) ifTrue:[
- "
- kludge: if its a wrapped method, then hide the wrap-call
- "
- caller := con sender.
- (caller notNil and:[caller receiver == method originalMethod]) ifTrue:[
- caller2 := caller sender.
- (caller2 notNil and:[caller2 method == method]) ifTrue:[
- con := caller2
- ]
- ].
- caller := caller2 := nil
- ].
- con := con sender
- ].
+ method := con method.
+ (method notNil and:[method isWrapped]) ifTrue:[
+ "
+ kludge: if its a wrapped method, then hide the wrap-call
+ "
+ caller := con sender.
+ (caller notNil and:[caller receiver == method originalMethod]) ifTrue:[
+ caller2 := caller sender.
+ (caller2 notNil and:[caller2 method == method]) ifTrue:[
+ con := caller2
+ ]
+ ].
+ caller := caller2 := nil
+ ].
+ con := con sender
+ ].
- "
- did we reach the end ?
- "
- con isNil ifTrue:[
- contextView middleButtonMenu disable:#doShowMore.
+ "
+ did we reach the end ?
+ "
+ (con isNil or:[con sender isNil]) ifTrue:[
- "
- the very last one is the startup context
- (in main) - it has nil as receiver and nil as selector
- "
- contextArray last selector isNil ifTrue:[
- contextArray removeLast.
- text removeLast
- ]
- ] ifFalse:[
- contextView middleButtonMenu enable:#doShowMore.
- ].
+ "
+ the very last one is the startup context
+ (in main) - it has nil as receiver and nil as selector
+ "
+ contextArray last selector isNil ifTrue:[
+ contextArray removeLast.
+ text removeLast
+ ]
+ ] ifFalse:[
+ m notNil ifTrue:[
+ m enable:#doShowMore.
+ text add:(resources string:'*** more walkback follows - click here to see them ***')
+ ].
+ ].
].
contextView setList: "list:" text.
receiverInspector release.
contextInspector release.
- contextView middleButtonMenu disable:#doRemoveBreakpoint.
- contextView middleButtonMenu disable:#doImplementors.
- contextView middleButtonMenu disable:#doSenders.
+ m notNil ifTrue:[
+ m disable:#doRemoveBreakpoint.
+ m disable:#doImplementors.
+ m disable:#doSenders.
+ ].
+!
+
+updateContext
+ |oldContext idx|
+
+ oldContext := selectedContext.
+ self setContext:(inspectedProcess suspendedContext).
+ oldContext notNil ifTrue:[
+ contextArray notNil ifTrue:[
+ idx := contextArray identityIndexOf:oldContext.
+ idx ~~ 0 ifTrue:[
+ self showSelection:idx
+ ] ifFalse:[
+ codeView contents:('** context returned **')
+ ]
+ ]
+ ]
! !
!DebugView methodsFor:'user interaction'!
@@ -938,65 +1056,79 @@
"user clicked on a header line - show selected code in textView"
|con homeContext sel method code
- implementorClass lineNrInMethod rec|
+ implementorClass lineNrInMethod rec m line|
contextArray notNil ifTrue:[
- con := contextArray at:lineNr.
- lineNrInMethod := con lineNumber.
- con isBlockContext ifTrue:[
- homeContext := con methodHome
- ] ifFalse:[
- homeContext := con
- ].
- contextInspector inspect:con.
- homeContext notNil ifTrue:[
- sel := homeContext selector.
- sel notNil ifTrue:[
- implementorClass := homeContext searchClass whichClassImplements:sel.
- implementorClass isNil ifTrue:[
- codeView contents:'** no method - no source **'
- ] ifFalse:[
- method := implementorClass compiledMethodAt:sel.
- code := method source.
- code isNil ifTrue:[
- method sourceFileName notNil ifTrue:[
- codeView contents:('** no sourcefile: ' ,
- method sourceFileName ,
- ' **')
- ] ifFalse:[
- codeView contents:'** no source **'
- ]
- ]
- ].
- code isNil ifTrue:[
- codeView acceptAction:nil.
- ] ifFalse:[
- codeView contents:code.
- (lineNrInMethod notNil and:[lineNrInMethod ~~ 0]) ifTrue:[
- lineNrInMethod > codeView list size ifTrue:[
- lineNrInMethod := codeView list size + 1
- ].
- codeView selectLine:lineNrInMethod.
- codeView makeSelectionVisible
- ].
- codeView acceptAction:[:code | self codeAccept:code asString]
- ].
+ lineNr <= contextArray size ifTrue:[
+ con := contextArray at:lineNr.
+ ].
+ "
+ clicking on the '** ...'-line shows more ...
+ "
+ con isNil ifTrue:[
+ line := contextView list at:lineNr.
+ (line startsWith:'**') ifTrue:[
+ self doShowMore.
+ contextView selection:lineNr.
+ con := contextArray at:lineNr
+ ]
+ ].
+ lineNrInMethod := con lineNumber.
+ con isBlockContext ifTrue:[
+ homeContext := con methodHome
+ ] ifFalse:[
+ homeContext := con
+ ].
+ contextInspector inspect:con.
+ homeContext notNil ifTrue:[
+ sel := homeContext selector.
+ sel notNil ifTrue:[
+ implementorClass := homeContext searchClass whichClassImplements:sel.
+ implementorClass isNil ifTrue:[
+ codeView contents:(resources string:'** no method - no source **')
+ ] ifFalse:[
+ method := implementorClass compiledMethodAt:sel.
+ code := method source.
+ code isNil ifTrue:[
+ method sourceFileName notNil ifTrue:[
+ codeView contents:(resources
+ string:'** no sourcefile: %1 **'
+ with:method sourceFileName)
+ ] ifFalse:[
+ codeView contents:(resources string:'** no source **')
+ ]
+ ]
+ ].
+ code isNil ifTrue:[
+ codeView acceptAction:nil.
+ ] ifFalse:[
+ codeView contents:code.
+ (lineNrInMethod notNil and:[lineNrInMethod ~~ 0]) ifTrue:[
+ lineNrInMethod > codeView list size ifTrue:[
+ lineNrInMethod := codeView list size + 1
+ ].
+ codeView selectLine:lineNrInMethod.
+ codeView makeSelectionVisible
+ ].
+ codeView acceptAction:[:code | self codeAccept:code asString]
+ ].
- "fetch rec here - so we wont need con in doItAction"
- rec := homeContext receiver.
- receiverInspector inspect:rec.
- codeView doItAction:[:theCode |
- rec class compiler
- evaluate:theCode
- in:nil
- receiver:rec
- notifying:codeView
- logged:true
- ifFail:nil
- ]
- ]
- ].
- selectedContext := homeContext
+ "fetch rec here - so we wont need context in doItAction"
+ rec := homeContext receiver.
+ ]
+ ].
+ receiverInspector inspect:rec.
+ codeView doItAction:[:theCode |
+ rec class compiler
+ evaluate:theCode
+ in:nil
+ receiver:rec
+ notifying:codeView
+ logged:true
+ ifFail:nil
+ ].
+
+ selectedContext := homeContext
].
"clear out locals to prevent keeping around unneeded contexts (due to the
block held in codeView).
@@ -1005,14 +1137,17 @@
con := nil.
homeContext := nil.
- contextView middleButtonMenu enable:#doImplementors.
- contextView middleButtonMenu enable:#doSenders.
- contextView middleButtonMenu enable:#doInspectContext.
+ m := contextView middleButtonMenu.
+ m notNil ifTrue:[
+ m enable:#doImplementors.
+ m enable:#doSenders.
+ m enable:#doInspectContext.
- (method notNil and:[method isWrapped]) ifTrue:[
- contextView middleButtonMenu enable:#doRemoveBreakpoint.
- ] ifFalse:[
- contextView middleButtonMenu disable:#doRemoveBreakpoint.
+ (method notNil and:[method isWrapped]) ifTrue:[
+ m enable:#doRemoveBreakpoint.
+ ] ifFalse:[
+ m disable:#doRemoveBreakpoint.
+ ]
]
!
@@ -1027,38 +1162,39 @@
codeView cursor:Cursor execute.
+ "
+ find the method-home context for this one
+ "
con := selectedContext.
top := con.
[con notNil] whileTrue:[
- (con methodHome == selectedContext) ifTrue:[
- top := con
- ].
- con := con sender
+ (con methodHome == selectedContext) ifTrue:[
+ top := con
+ ].
+ con := con sender
].
"now, remove everything up to and including top from context chain"
-"
- self setContext:(top sender).
-"
-
sel := selectedContext selector.
implementorClass := selectedContext searchClass whichClassImplements:sel.
method := implementorClass compiledMethodAt:sel.
newMethod := implementorClass compiler compile:someCode
- forClass:implementorClass
- inCategory:(method category)
- notifying:codeView.
+ forClass:implementorClass
+ inCategory:(method category)
+ notifying:codeView.
- "if it worked, remove everything up to and including top
- from context chain"
+ inspecting ifFalse:[
+ "if it worked, remove everything up to and including top
+ from context chain"
- (newMethod notNil and:[newMethod ~~ #Error]) ifTrue:[
- self setContext:(top sender).
+ (newMethod notNil and:[newMethod ~~ #Error]) ifTrue:[
+ self setContext:(top sender).
- "continue/step is no longer possible"
- canContinue := false.
- self showSelection:1.
- exitAction := #return
+ "continue/step is no longer possible"
+ canContinue := false.
+ self showSelection:1.
+ exitAction := #return
+ ].
].
codeView cursor:Cursor normal
!
@@ -1070,13 +1206,15 @@
receiverInspector release.
contextInspector release.
inspecting ifFalse:[
- canAbort ifTrue:[
- self doAbort.
- 'oops, abort failed' errorPrintNewline.
- ] ifFalse:[
- self doContinue
- ]
+ canAbort ifTrue:[
+ self doAbort.
+ 'oops, abort failed' errorPrintNewline.
+ ] ifFalse:[
+ self doContinue
+ ]
].
+ self autoUpdateOff.
+ inspectedProcess := nil.
super destroy
!
@@ -1092,12 +1230,12 @@
|implementorClass method|
implementorClass := selectedContext searchClass
- whichClassImplements:selectedContext selector.
+ whichClassImplements:selectedContext selector.
implementorClass notNil ifTrue:[
- method := implementorClass compiledMethodAt:selectedContext selector.
- (method notNil and:[method isWrapped]) ifTrue:[
- MessageTracer unwrapMethod:method
- ]
+ method := implementorClass compiledMethodAt:selectedContext selector.
+ (method notNil and:[method isWrapped]) ifTrue:[
+ MessageTracer unwrapMethod:method
+ ]
].
contextView middleButtonMenu disable:#doRemoveBreakpoint.
!
@@ -1106,7 +1244,7 @@
"open a browser on the senders"
selectedContext notNil ifTrue:[
- SystemBrowser browseAllCallsOn:selectedContext selector.
+ SystemBrowser browseAllCallsOn:selectedContext selector.
]
!
@@ -1114,7 +1252,7 @@
"open a browser on the implementors"
selectedContext notNil ifTrue:[
- SystemBrowser browseImplementorsOf:selectedContext selector.
+ SystemBrowser browseImplementorsOf:selectedContext selector.
]
!
@@ -1124,10 +1262,10 @@
|oldSelection|
contextArray notNil ifTrue:[
- oldSelection := contextView selection.
- nChainShown := nChainShown * 2.
- self setContext:contextArray first.
- contextView selection:oldSelection.
+ oldSelection := contextView selection.
+ nChainShown := nChainShown * 2.
+ self setContext:contextArray first.
+ contextView selection:oldSelection.
]
!
@@ -1137,16 +1275,16 @@
inspecting ifTrue:[^ self].
canContinue ifTrue:[
- steppedContextAddress := nil.
- haveControl := false.
- exitAction := #step.
- ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[catchBlock value].
- 'oops, send failed' errorPrintNewline.
- self warn:'send failed'.
- sendButton turnOff; disable.
- ].
+ steppedContextAddress := nil.
+ haveControl := false.
+ exitAction := #step.
+ ProcessorScheduler isPureEventDriven ifFalse:[
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ 'oops, send failed' errorPrintNewline.
+ self warn:'send failed'.
+ sendButton turnOff; disable.
+ ].
]
!
@@ -1156,21 +1294,21 @@
inspecting ifTrue:[^ self].
canContinue ifTrue:[
- selectedContext notNil ifTrue:[
- steppedContextAddress := ObjectMemory addressOf:selectedContext
- ] ifFalse:[
- steppedContextAddress := ObjectMemory addressOf:(contextArray at:2)
- ].
- bigStep := true.
- haveControl := false.
- exitAction := #step.
- ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[catchBlock value].
- 'oops, step failed' errorPrintNewline.
- self warn:'step failed'.
- stepButton turnOff; disable.
- ].
+ selectedContext notNil ifTrue:[
+ steppedContextAddress := ObjectMemory addressOf:selectedContext
+ ] ifFalse:[
+ steppedContextAddress := ObjectMemory addressOf:(contextArray at:2)
+ ].
+ bigStep := true.
+ haveControl := false.
+ exitAction := #step.
+ ProcessorScheduler isPureEventDriven ifFalse:[
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ 'oops, step failed' errorPrintNewline.
+ self warn:'step failed'.
+ stepButton turnOff; disable.
+ ].
]
!
@@ -1178,89 +1316,169 @@
"tracestep - not implemented yet"
canContinue ifTrue:[
- tracing := true.
- self doStep
+ tracing := true.
+ self doStep
]
!
doAbort
"abort from menu"
- inspecting ifTrue:[^ self].
+ inspecting ifTrue:[
+ inspectedProcess id isNil ifTrue:[
+ codeView contents:(resources string:'** process has terminated **')
+ ] ifFalse:[
+ inspectedProcess interruptWith:[Object abortSignal raise].
+ "
+ give it a chance to run, then update
+ "
+ (Delay forSeconds:0.2) wait.
+ self setContext:(inspectedProcess suspendedContext).
+ ].
+ ^ self
+ ].
steppedContextAddress := nil.
haveControl := false.
exitAction := #abort.
ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[
- abortButton turnOff.
- catchBlock value.
- 'oops, abort failed' errorPrintNewline.
- self warn:'unwind failed'.
- abortButton disable.
- ]
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[
+ abortButton turnOff.
+ catchBlock value.
+ 'oops, abort failed' errorPrintNewline.
+ self warn:'unwind failed'.
+ abortButton disable.
+ ]
].
^ self.
"obsolete ..."
Processor activeProcess id == 0 ifTrue:[
- "dont allow termination of main-thread"
- exitAction := #abort
+ "dont allow termination of main-thread"
+ exitAction := #abort
] ifFalse:[
- exitAction := #terminate
+ exitAction := #terminate
]
!
doTerminate
"terminate from menu"
+ inspecting ifTrue:[
+ inspectedProcess id isNil ifTrue:[
+ codeView contents:(resources string:'** process has already terminated **')
+ ] ifFalse:[
+ inspectedProcess terminate.
+ "
+ give it a chance to run, then update
+ "
+ (Delay forSeconds:0.2) wait.
+ self setContext:(inspectedProcess suspendedContext).
+ ].
+ ^ self
+ ].
+
steppedContextAddress := nil.
haveControl := false.
exitAction := #terminate.
ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[catchBlock value].
- inspecting ifFalse:[
- 'oops, terminate failed' errorPrintNewline.
- self warn:'terminate failed'.
- ].
- terminateButton turnOff; disable.
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ inspecting ifFalse:[
+ 'oops, terminate failed' errorPrintNewline.
+ self warn:'terminate failed'.
+ ].
+ terminateButton turnOff; disable.
].
!
+doQuickTerminate
+ "terminate from menu"
+
+ inspecting ifTrue:[
+ inspectedProcess id isNil ifTrue:[
+ codeView contents:(resources string:'** process has already terminated **')
+ ] ifFalse:[
+ inspectedProcess terminateNoSignal.
+ "
+ give it a chance to run, then update
+ "
+ (Delay forSeconds:0.2) wait.
+ self setContext:(inspectedProcess suspendedContext).
+ ].
+ ^ self
+ ].
+
+ steppedContextAddress := nil.
+ haveControl := false.
+ exitAction := #quickTerminate.
+ ProcessorScheduler isPureEventDriven ifFalse:[
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ inspecting ifFalse:[
+ 'oops, terminate failed' errorPrintNewline.
+ self warn:'terminate failed'.
+ ].
+ terminateButton turnOff; disable.
+ ].
+!
doReturn
"return from menu"
- inspecting ifTrue:[^ self].
+ inspecting ifTrue:[
+ inspectedProcess id isNil ifTrue:[
+ codeView contents:(resources string:'** process has terminated **')
+ ] ifFalse:[
+ inspectedProcess interruptWith:[selectedContext return].
+ "
+ give it a chance to run, then update
+ "
+ (Delay forSeconds:0.2) wait.
+ self setContext:(inspectedProcess suspendedContext).
+ ].
+ ^ self
+ ].
steppedContextAddress := nil.
haveControl := false.
exitAction := #return.
ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[catchBlock value].
- 'oops, return failed' errorPrintNewline.
- self warn:'return failed'.
- returnButton turnOff; disable.
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ 'oops, return failed' errorPrintNewline.
+ self warn:'return failed'.
+ returnButton turnOff; disable.
].
!
doRestart
"restart from menu"
- inspecting ifTrue:[^ self].
+ inspecting ifTrue:[
+ inspectedProcess id isNil ifTrue:[
+ codeView contents:(resources string:'** process has terminated **')
+ ] ifFalse:[
+ inspectedProcess interruptWith:[selectedContext restart].
+ "
+ give it a chance to run, then update
+ "
+ (Delay forSeconds:0.2) wait.
+ self setContext:(inspectedProcess suspendedContext).
+ ].
+ ^ self
+ ].
steppedContextAddress := nil.
haveControl := false.
exitAction := #restart.
ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[catchBlock value].
- 'oops, restart failed' errorPrintNewline.
- self warn:'restart failed'.
- restartButton turnOff; disable
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ 'oops, restart failed' errorPrintNewline.
+ self warn:'restart failed'.
+ restartButton turnOff; disable
].
!
@@ -1273,21 +1491,21 @@
false ifTrue:[
traceView isNil ifTrue:[
- v := StandardSystemView on:Display.
- v label:'Debugger-Trace'.
- v icon:icon.
+ v := StandardSystemView on:Display.
+ v label:'Debugger-Trace'.
+ v icon:icon.
- b := Button label:'untrace' in:v.
- b origin:(0 @ 0) extent:(1.0 @ (b height)).
- b action:[
- StepInterruptPending := false.
- tracing := false.
- v unrealize.
- traceView := nil
- ].
- traceView := ScrollableView for:TextCollector in:v.
- traceView origin:(0 @ (b height))
- extent:[v width @ (v height - b height)]
+ b := Button label:'untrace' in:v.
+ b origin:(0 @ 0) extent:(1.0 @ (b height)).
+ b action:[
+ StepInterruptPending := false.
+ tracing := false.
+ v unrealize.
+ traceView := nil
+ ].
+ traceView := ScrollableView for:TextCollector in:v.
+ traceView origin:(0 @ (b height))
+ extent:[v width @ (v height - b height)]
].
v realize.
].
@@ -1296,40 +1514,102 @@
doNoTrace
traceView notNil ifTrue:[
- traceView topView destroy.
- traceView := nil.
+ traceView topView destroy.
+ traceView := nil.
].
tracing := false
!
+doStop
+ "stop the process (if its running, otherwise this is a no-op)"
+
+ inspecting ifTrue:[
+ inspectedProcess id isNil ifTrue:[
+ codeView contents:(resources string:'** process has terminated **')
+ ] ifFalse:[
+ inspectedProcess suspend.
+ self setContext:(inspectedProcess suspendedContext).
+ ].
+ ^ self
+ ].
+!
+
doContinue
"continue from menu"
+ inspecting ifTrue:[
+ inspectedProcess id isNil ifTrue:[
+ codeView contents:(resources string:'** process has terminated **')
+ ] ifFalse:[
+ inspectedProcess resume.
+ "
+ give it a chance to run, then update
+ "
+ (Delay forSeconds:0.2) wait.
+ self setContext:(inspectedProcess suspendedContext).
+ ].
+ ^ self
+ ].
canContinue ifTrue:[
- steppedContextAddress := nil.
- tracing := false.
- haveControl := false.
- exitAction := #continue.
- ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[catchBlock value].
- 'oops, continue failed' errorPrintNewline.
- self warn:'continue failed'.
- continueButton turnOff; disable
- ].
+ steppedContextAddress := nil.
+ tracing := false.
+ haveControl := false.
+ exitAction := #continue.
+ ProcessorScheduler isPureEventDriven ifFalse:[
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ 'oops, continue failed' errorPrintNewline.
+ self warn:'continue failed'.
+ continueButton turnOff; disable
+ ].
] ifFalse:[
- inspecting ifFalse:[
- 'resuming top context' errorPrintNewline.
- self showSelection:1.
- self doReturn
- ]
+ inspecting ifFalse:[
+ 'resuming top context' errorPrintNewline.
+ self showSelection:1.
+ self doReturn
+ ]
]
!
doInspectContext
"launch an inspector on the currently selected context"
- selectedContext notNil ifTrue:[
- selectedContext inspect
+ contextView selection notNil ifTrue:[
+ (contextView selectionValue startsWith:'**') ifFalse:[
+ (contextArray at:(contextView selection)) inspect.
+ ]
+ ]
+!
+
+autoUpdateOff
+ updateProcess notNil ifTrue:[
+ monitorToggle lampColor:(Color yellow).
+ updateProcess terminate.
+ updateProcess := nil
]
+!
+
+autoUpdateOn
+ updateProcess isNil ifTrue:[
+ updateProcess :=
+ [
+ [true] whileTrue:[
+ monitorToggle showLamp ifTrue:[
+ monitorToggle lampColor:(Color yellow).
+ ] ifFalse:[
+ monitorToggle activeForegroundColor:Color black.
+ ].
+ (Delay forSeconds:0.25) wait.
+ self updateContext.
+ monitorToggle showLamp ifTrue:[
+ monitorToggle lampColor:(Color red).
+ ] ifFalse:[
+ monitorToggle activeForegroundColor:Color red.
+ ].
+ (Delay forSeconds:0.25) wait.
+ self updateContext.
+ ]
+ ] forkAt:(Processor activePriority - 1)
+ ]
+
! !
--- a/DictInspV.st Mon Oct 10 04:15:21 1994 +0100
+++ b/DictInspV.st Mon Oct 10 04:16:24 1994 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.7 1994-10-10 03:15:31 claus Exp $
'!
!DictionaryInspectorView class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.7 1994-10-10 03:15:31 claus Exp $
"
!
@@ -141,6 +141,19 @@
self inspect:inspectedObject. "force list update"
].
]
+!
+
+doReferences
+ "show users of selected key (i.e. global)"
+
+ |k|
+
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ k := (keys at:selectedLine - 1).
+ SystemBrowser browseReferendsOf:k asSymbol
+ ].
+ ]
! !
!DictionaryInspectorView methodsFor:'accessing'!
@@ -168,17 +181,29 @@
!DictionaryInspectorView methodsFor:'initialization'!
-initializeListViewMiddleButtonMenu
- |labels|
+initializeListViewMiddleButtonMenus
+ |labels selectors|
- labels := resources array:#(
- 'inspect'
- '-'
- 'add key'
- 'remove key').
- listView middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(doInspect nil doAddKey doRemoveKey)
+ inspectedObject == Smalltalk ifTrue:[
+ labels := resources array:#(
+ 'inspect'
+ 'references'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect doReferences nil doAddKey doRemoveKey).
+ ] ifFalse:[
+ labels := resources array:#(
+ 'inspect'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect nil doAddKey doRemoveKey).
+ ].
+
+ menu1 := (PopUpMenu
+ labels:(resources array:labels)
+ selectors:selectors
receiver:self
for:listView).
workspace acceptAction:[:theText | self doAccept:theText asString]
--- a/DictionaryInspectorView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/DictionaryInspectorView.st Mon Oct 10 04:16:24 1994 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.7 1994-10-10 03:15:31 claus Exp $
'!
!DictionaryInspectorView class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.7 1994-10-10 03:15:31 claus Exp $
"
!
@@ -141,6 +141,19 @@
self inspect:inspectedObject. "force list update"
].
]
+!
+
+doReferences
+ "show users of selected key (i.e. global)"
+
+ |k|
+
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ k := (keys at:selectedLine - 1).
+ SystemBrowser browseReferendsOf:k asSymbol
+ ].
+ ]
! !
!DictionaryInspectorView methodsFor:'accessing'!
@@ -168,17 +181,29 @@
!DictionaryInspectorView methodsFor:'initialization'!
-initializeListViewMiddleButtonMenu
- |labels|
+initializeListViewMiddleButtonMenus
+ |labels selectors|
- labels := resources array:#(
- 'inspect'
- '-'
- 'add key'
- 'remove key').
- listView middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(doInspect nil doAddKey doRemoveKey)
+ inspectedObject == Smalltalk ifTrue:[
+ labels := resources array:#(
+ 'inspect'
+ 'references'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect doReferences nil doAddKey doRemoveKey).
+ ] ifFalse:[
+ labels := resources array:#(
+ 'inspect'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect nil doAddKey doRemoveKey).
+ ].
+
+ menu1 := (PopUpMenu
+ labels:(resources array:labels)
+ selectors:selectors
receiver:self
for:listView).
workspace acceptAction:[:theText | self doAccept:theText asString]
--- a/DiffTextView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/DiffTextView.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +13,17 @@
"
TwoColumnTextView subclass:#DiffTextView
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Views-Text'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
!
DiffTextView comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.3 1994-10-10 03:15:33 claus Exp $
'!
!DiffTextView class methodsFor:'documentation'!
@@ -31,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,21 +44,30 @@
version
"
-$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.3 1994-10-10 03:15:33 claus Exp $
"
!
documentation
"
- a view showing diff output in a user-friendly form.
+ a view showing diff (see unix manual pages) output in a
+ user-friendly form.
The view is created and opened with:
d := DiffTextView openOn:text1 and:text2.
and it will show the differences side-by-side
+ For a real world application, see the ChangesBrowsers
+ compare function.
"
! !
+!DiffTextView class methodsFor:'defaults'!
+
+diffCommand
+ ^ 'diff -b'
+! !
+
!DiffTextView methodsFor:'private'!
updateListsFrom:text1 and:text2 diffs:diffList
@@ -74,150 +83,150 @@
dEnd := diffList size + 1.
state := #initial.
[dIdx <= dEnd] whileTrue:[
- dIdx == dEnd ifTrue:[
- "dummy cleanup entry"
- entry := nil.
- state := #initial.
- ] ifFalse:[
- entry := diffList at:dIdx.
- ].
+ dIdx == dEnd ifTrue:[
+ "dummy cleanup entry"
+ entry := nil.
+ state := #initial.
+ ] ifFalse:[
+ entry := diffList at:dIdx.
+ ].
- state == #initial ifTrue:[
- "entry is of the form <nr> <op> <offs> [<offs2>]"
+ state == #initial ifTrue:[
+ "entry is of the form <nr> <op> <offs> [<offs2>]"
- "
- fill up to size difference from previous change
- "
- delta := l1 size - l2 size.
- delta > 0 ifTrue:[
- delta timesRepeat:[l2 add:nil]
- ] ifFalse:[
- delta < 0 ifTrue:[
- delta negated timesRepeat:[l1 add:nil]
- ]
- ].
+ "
+ fill up to size difference from previous change
+ "
+ delta := l1 size - l2 size.
+ delta > 0 ifTrue:[
+ delta timesRepeat:[l2 add:nil]
+ ] ifFalse:[
+ delta < 0 ifTrue:[
+ delta negated timesRepeat:[l1 add:nil]
+ ]
+ ].
- "
- except for the first chunk, add a separating line
- "
- l1 size ~~ 0 ifTrue:[
- l1 add:'--------'.
- l2 add:'--------'.
- ].
+ "
+ except for the first chunk, add a separating line
+ "
+ l1 size ~~ 0 ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ].
- "
- in cleanup ?
- "
- entry isNil ifTrue:[
- nr1 := text1 size + 1.
- nr2 := text2 size + 1.
- state := #finish.
- ] ifFalse:[
- s := ReadStream on:entry.
- nr1 := Integer readFrom:s.
- s peek == $, ifTrue:[
- s next.
- Integer readFrom:s
- ].
- op := s next.
- nr2 := Integer readFrom:s.
- s peek == $, ifTrue:[
- s next.
- nr3 := Integer readFrom:s
- ] ifFalse:[
- nr3 := nil
- ].
+ "
+ in cleanup ?
+ "
+ entry isNil ifTrue:[
+ nr1 := text1 size + 1.
+ nr2 := text2 size + 1.
+ state := #finish.
+ ] ifFalse:[
+ s := ReadStream on:entry.
+ nr1 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ Integer readFrom:s
+ ].
+ op := s next.
+ nr2 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ nr3 := Integer readFrom:s
+ ] ifFalse:[
+ nr3 := nil
+ ].
- op == $c ifTrue:[
- state := #changed.
- ] ifFalse:[
- op == $a ifTrue:[
- state := #added.
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1.
- ] ifFalse:[
- op == $d ifTrue:[
- state := #deleted
- ]
- ]
- ].
+ op == $c ifTrue:[
+ state := #changed.
+ ] ifFalse:[
+ op == $a ifTrue:[
+ state := #added.
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ ] ifFalse:[
+ op == $d ifTrue:[
+ state := #deleted
+ ]
+ ]
+ ].
- ].
+ ].
- "
- copy over unchanged lines
- "
- any := false.
- [idx1 < nr1] whileTrue:[
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1.
- any := true.
- ].
- [idx2 < nr2] whileTrue:[
- l2 add:(text2 at:idx2).
- idx2 := idx2 + 1.
- any := true.
- ].
+ "
+ copy over unchanged lines
+ "
+ any := false.
+ [idx1 < nr1] whileTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ any := true.
+ ].
+ [idx2 < nr2] whileTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ any := true.
+ ].
- "
- add a separating line, except at end
- "
- any ifTrue:[
- state ~~ #finish ifTrue:[
- l1 add:'--------'.
- l2 add:'--------'.
- ]
- ].
+ "
+ add a separating line, except at end
+ "
+ any ifTrue:[
+ state ~~ #finish ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ]
+ ].
- ] ifFalse:[
- state == #changed ifTrue:[
- (entry at:1) == $< ifTrue:[
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1
- ] ifFalse:[
- (entry at:1) == $> ifTrue:[
- l2 add:(text2 at:idx2).
- idx2 := idx2 + 1
- ] ifFalse:[
- (entry at:1) == $- ifTrue:[
- ] ifFalse:[
- state := #initial.
- dIdx := dIdx - 1
- ]
- ]
- ]
- ] ifFalse:[
- state == #added ifTrue:[
- (entry at:1) == $> ifTrue:[
- l2 add:(text2 at:idx2).
- idx2 := idx2 + 1.
- l1 add:nil
- ] ifFalse:[
- state := #initial.
- dIdx := dIdx - 1
- ]
- ] ifFalse:[
- state == #deleted ifTrue:[
- (entry at:1) == $< ifTrue:[
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1.
- l2 add:nil
- ] ifFalse:[
- state := #initial.
- dIdx := dIdx - 1
- ]
- ]
- "must be in finish otherwise"
- ]
- ]
- ].
- dIdx := dIdx + 1
+ ] ifFalse:[
+ state == #changed ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1
+ ] ifFalse:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1
+ ] ifFalse:[
+ (entry at:1) == $- ifTrue:[
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ state == #added ifTrue:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ l1 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ] ifFalse:[
+ state == #deleted ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ l2 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ "must be in finish otherwise"
+ ]
+ ]
+ ].
+ dIdx := dIdx + 1
].
[l1 size < l2 size] whileTrue:[
- l1 add:''.
+ l1 add:''.
].
[l2 size < l1 size] whileTrue:[
- l2 add:''.
+ l2 add:''.
].
textView1 list:l1.
textView2 list:l2
@@ -239,31 +248,36 @@
stream := tmpName1 asFilename writeStream.
text1 do:[:line |
- stream nextPutAll:line; cr
+ stream nextPutAll:line; cr
].
stream close.
stream := tmpName2 asFilename writeStream.
text2 do:[:line |
- stream nextPutAll:line; cr
+ stream nextPutAll:line; cr
].
stream close.
"
start diff on it ...
"
- stream := PipeStream readingFrom:'diff ' , tmpName1 , ' ' , tmpName2.
+ stream := PipeStream
+ readingFrom:self class diffCommand , ' ' ,
+ tmpName1 , ' ' , tmpName2.
stream isNil ifTrue:[
- self error:'cannot execute diff'.
- text1 := text2 := nil.
- ^ nil
+ self error:'cannot execute diff'.
+ text1 := text2 := nil.
+ ] ifFalse:[
+ diffList := OrderedCollection new.
+ [stream atEnd] whileFalse:[
+ line := stream nextLine.
+ line notNil ifTrue:[diffList add:line]
+ ].
+ stream close.
].
- diffList := OrderedCollection new.
- [stream atEnd] whileFalse:[
- line := stream nextLine.
- line notNil ifTrue:[diffList add:line]
- ].
- stream close.
+
+ tmpName1 asFilename delete.
+ tmpName2 asFilename delete.
self updateListsFrom:text1 and:text2 diffs:diffList
@@ -272,7 +286,7 @@
v := HVScrollableView for:DiffTextView.
v scrolledView text1:('../libview/Color.st' asFilename readStream contents)
- text2:('../libview/Color.st.old' asFilename readStream contents).
+ text2:('../libview/Color.st.old' asFilename readStream contents).
v open
"
--- a/DiffTxtV.st Mon Oct 10 04:15:21 1994 +0100
+++ b/DiffTxtV.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +13,17 @@
"
TwoColumnTextView subclass:#DiffTextView
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Views-Text'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
!
DiffTextView comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.3 1994-10-10 03:15:33 claus Exp $
'!
!DiffTextView class methodsFor:'documentation'!
@@ -31,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,21 +44,30 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.3 1994-10-10 03:15:33 claus Exp $
"
!
documentation
"
- a view showing diff output in a user-friendly form.
+ a view showing diff (see unix manual pages) output in a
+ user-friendly form.
The view is created and opened with:
d := DiffTextView openOn:text1 and:text2.
and it will show the differences side-by-side
+ For a real world application, see the ChangesBrowsers
+ compare function.
"
! !
+!DiffTextView class methodsFor:'defaults'!
+
+diffCommand
+ ^ 'diff -b'
+! !
+
!DiffTextView methodsFor:'private'!
updateListsFrom:text1 and:text2 diffs:diffList
@@ -74,150 +83,150 @@
dEnd := diffList size + 1.
state := #initial.
[dIdx <= dEnd] whileTrue:[
- dIdx == dEnd ifTrue:[
- "dummy cleanup entry"
- entry := nil.
- state := #initial.
- ] ifFalse:[
- entry := diffList at:dIdx.
- ].
+ dIdx == dEnd ifTrue:[
+ "dummy cleanup entry"
+ entry := nil.
+ state := #initial.
+ ] ifFalse:[
+ entry := diffList at:dIdx.
+ ].
- state == #initial ifTrue:[
- "entry is of the form <nr> <op> <offs> [<offs2>]"
+ state == #initial ifTrue:[
+ "entry is of the form <nr> <op> <offs> [<offs2>]"
- "
- fill up to size difference from previous change
- "
- delta := l1 size - l2 size.
- delta > 0 ifTrue:[
- delta timesRepeat:[l2 add:nil]
- ] ifFalse:[
- delta < 0 ifTrue:[
- delta negated timesRepeat:[l1 add:nil]
- ]
- ].
+ "
+ fill up to size difference from previous change
+ "
+ delta := l1 size - l2 size.
+ delta > 0 ifTrue:[
+ delta timesRepeat:[l2 add:nil]
+ ] ifFalse:[
+ delta < 0 ifTrue:[
+ delta negated timesRepeat:[l1 add:nil]
+ ]
+ ].
- "
- except for the first chunk, add a separating line
- "
- l1 size ~~ 0 ifTrue:[
- l1 add:'--------'.
- l2 add:'--------'.
- ].
+ "
+ except for the first chunk, add a separating line
+ "
+ l1 size ~~ 0 ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ].
- "
- in cleanup ?
- "
- entry isNil ifTrue:[
- nr1 := text1 size + 1.
- nr2 := text2 size + 1.
- state := #finish.
- ] ifFalse:[
- s := ReadStream on:entry.
- nr1 := Integer readFrom:s.
- s peek == $, ifTrue:[
- s next.
- Integer readFrom:s
- ].
- op := s next.
- nr2 := Integer readFrom:s.
- s peek == $, ifTrue:[
- s next.
- nr3 := Integer readFrom:s
- ] ifFalse:[
- nr3 := nil
- ].
+ "
+ in cleanup ?
+ "
+ entry isNil ifTrue:[
+ nr1 := text1 size + 1.
+ nr2 := text2 size + 1.
+ state := #finish.
+ ] ifFalse:[
+ s := ReadStream on:entry.
+ nr1 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ Integer readFrom:s
+ ].
+ op := s next.
+ nr2 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ nr3 := Integer readFrom:s
+ ] ifFalse:[
+ nr3 := nil
+ ].
- op == $c ifTrue:[
- state := #changed.
- ] ifFalse:[
- op == $a ifTrue:[
- state := #added.
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1.
- ] ifFalse:[
- op == $d ifTrue:[
- state := #deleted
- ]
- ]
- ].
+ op == $c ifTrue:[
+ state := #changed.
+ ] ifFalse:[
+ op == $a ifTrue:[
+ state := #added.
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ ] ifFalse:[
+ op == $d ifTrue:[
+ state := #deleted
+ ]
+ ]
+ ].
- ].
+ ].
- "
- copy over unchanged lines
- "
- any := false.
- [idx1 < nr1] whileTrue:[
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1.
- any := true.
- ].
- [idx2 < nr2] whileTrue:[
- l2 add:(text2 at:idx2).
- idx2 := idx2 + 1.
- any := true.
- ].
+ "
+ copy over unchanged lines
+ "
+ any := false.
+ [idx1 < nr1] whileTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ any := true.
+ ].
+ [idx2 < nr2] whileTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ any := true.
+ ].
- "
- add a separating line, except at end
- "
- any ifTrue:[
- state ~~ #finish ifTrue:[
- l1 add:'--------'.
- l2 add:'--------'.
- ]
- ].
+ "
+ add a separating line, except at end
+ "
+ any ifTrue:[
+ state ~~ #finish ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ]
+ ].
- ] ifFalse:[
- state == #changed ifTrue:[
- (entry at:1) == $< ifTrue:[
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1
- ] ifFalse:[
- (entry at:1) == $> ifTrue:[
- l2 add:(text2 at:idx2).
- idx2 := idx2 + 1
- ] ifFalse:[
- (entry at:1) == $- ifTrue:[
- ] ifFalse:[
- state := #initial.
- dIdx := dIdx - 1
- ]
- ]
- ]
- ] ifFalse:[
- state == #added ifTrue:[
- (entry at:1) == $> ifTrue:[
- l2 add:(text2 at:idx2).
- idx2 := idx2 + 1.
- l1 add:nil
- ] ifFalse:[
- state := #initial.
- dIdx := dIdx - 1
- ]
- ] ifFalse:[
- state == #deleted ifTrue:[
- (entry at:1) == $< ifTrue:[
- l1 add:(text1 at:idx1).
- idx1 := idx1 + 1.
- l2 add:nil
- ] ifFalse:[
- state := #initial.
- dIdx := dIdx - 1
- ]
- ]
- "must be in finish otherwise"
- ]
- ]
- ].
- dIdx := dIdx + 1
+ ] ifFalse:[
+ state == #changed ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1
+ ] ifFalse:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1
+ ] ifFalse:[
+ (entry at:1) == $- ifTrue:[
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ state == #added ifTrue:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ l1 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ] ifFalse:[
+ state == #deleted ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ l2 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ "must be in finish otherwise"
+ ]
+ ]
+ ].
+ dIdx := dIdx + 1
].
[l1 size < l2 size] whileTrue:[
- l1 add:''.
+ l1 add:''.
].
[l2 size < l1 size] whileTrue:[
- l2 add:''.
+ l2 add:''.
].
textView1 list:l1.
textView2 list:l2
@@ -239,31 +248,36 @@
stream := tmpName1 asFilename writeStream.
text1 do:[:line |
- stream nextPutAll:line; cr
+ stream nextPutAll:line; cr
].
stream close.
stream := tmpName2 asFilename writeStream.
text2 do:[:line |
- stream nextPutAll:line; cr
+ stream nextPutAll:line; cr
].
stream close.
"
start diff on it ...
"
- stream := PipeStream readingFrom:'diff ' , tmpName1 , ' ' , tmpName2.
+ stream := PipeStream
+ readingFrom:self class diffCommand , ' ' ,
+ tmpName1 , ' ' , tmpName2.
stream isNil ifTrue:[
- self error:'cannot execute diff'.
- text1 := text2 := nil.
- ^ nil
+ self error:'cannot execute diff'.
+ text1 := text2 := nil.
+ ] ifFalse:[
+ diffList := OrderedCollection new.
+ [stream atEnd] whileFalse:[
+ line := stream nextLine.
+ line notNil ifTrue:[diffList add:line]
+ ].
+ stream close.
].
- diffList := OrderedCollection new.
- [stream atEnd] whileFalse:[
- line := stream nextLine.
- line notNil ifTrue:[diffList add:line]
- ].
- stream close.
+
+ tmpName1 asFilename delete.
+ tmpName2 asFilename delete.
self updateListsFrom:text1 and:text2 diffs:diffList
@@ -272,7 +286,7 @@
v := HVScrollableView for:DiffTextView.
v scrolledView text1:('../libview/Color.st' asFilename readStream contents)
- text2:('../libview/Color.st.old' asFilename readStream contents).
+ text2:('../libview/Color.st.old' asFilename readStream contents).
v open
"
--- a/EvMonitor.st Mon Oct 10 04:15:21 1994 +0100
+++ b/EvMonitor.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,10 +1,10 @@
'From Smalltalk/X, Version:1.4 on 19-Jul-91 at 18:34:01'!
StandardSystemView subclass:#EventMonitor
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Views-Demo'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
EventMonitor comment:'
@@ -31,35 +31,60 @@
keyPress:key x:x y:y
'KeyPress x:' print. x print. ' y:' print. y print.
(key isMemberOf:Character) ifTrue:[
- ' character key:' print. key print.
- ' (' print. key asciiValue print. ')' print
+ ' character key:' print. key print.
+ ' (' print. key asciiValue print. ')' print
] ifFalse:[
- ' symbolic key:' print. key print
+ ' symbolic key:' print. key print
].
- '' printNewline
+ '' printNL
+!
+
+keyRelease:key x:x y:y
+ 'KeyRelease x:' print. x print. ' y:' print. y print.
+ (key isMemberOf:Character) ifTrue:[
+ ' character key:' print. key print.
+ ' (' print. key asciiValue print. ')' print
+ ] ifFalse:[
+ ' symbolic key:' print. key print
+ ].
+
+ '' printNL
!
buttonPress:button x:x y:y
'buttonPress x:' print. x print. ' y:' print. y print.
- ' button:' print. button printNewline
+ ' button:' print. button printNL
!
buttonRelease:button x:x y:y
'buttonRelease x:' print. x print. ' y:' print. y print.
- ' button:' print. button printNewline
+ ' button:' print. button printNL
!
buttonMotion:button x:x y:y
'buttonMotion x:' print. x print. ' y:' print. y print.
- ' button:' print. button printNewline
+ ' button:' print. button printNL
+!
+
+mapped
+ 'mapped' printNL
+!
+
+unmapped
+ 'unmapped' printNL
+!
+
+visibilityChange:how
+ 'visibilityChange:' print. how printNL
! !
!EventMonitor methodsFor:'realization'!
initEvents
- self enableKeyEvents.
self enableButtonEvents.
self enableMotionEvents.
- self enableButtonMotionEvents
+ self enableButtonMotionEvents.
+ self enableKeyReleaseEvents.
+ self enableEvent:#visibilityChange
! !
--- a/EventMonitor.st Mon Oct 10 04:15:21 1994 +0100
+++ b/EventMonitor.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,10 +1,10 @@
'From Smalltalk/X, Version:1.4 on 19-Jul-91 at 18:34:01'!
StandardSystemView subclass:#EventMonitor
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Views-Demo'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
EventMonitor comment:'
@@ -31,35 +31,60 @@
keyPress:key x:x y:y
'KeyPress x:' print. x print. ' y:' print. y print.
(key isMemberOf:Character) ifTrue:[
- ' character key:' print. key print.
- ' (' print. key asciiValue print. ')' print
+ ' character key:' print. key print.
+ ' (' print. key asciiValue print. ')' print
] ifFalse:[
- ' symbolic key:' print. key print
+ ' symbolic key:' print. key print
].
- '' printNewline
+ '' printNL
+!
+
+keyRelease:key x:x y:y
+ 'KeyRelease x:' print. x print. ' y:' print. y print.
+ (key isMemberOf:Character) ifTrue:[
+ ' character key:' print. key print.
+ ' (' print. key asciiValue print. ')' print
+ ] ifFalse:[
+ ' symbolic key:' print. key print
+ ].
+
+ '' printNL
!
buttonPress:button x:x y:y
'buttonPress x:' print. x print. ' y:' print. y print.
- ' button:' print. button printNewline
+ ' button:' print. button printNL
!
buttonRelease:button x:x y:y
'buttonRelease x:' print. x print. ' y:' print. y print.
- ' button:' print. button printNewline
+ ' button:' print. button printNL
!
buttonMotion:button x:x y:y
'buttonMotion x:' print. x print. ' y:' print. y print.
- ' button:' print. button printNewline
+ ' button:' print. button printNL
+!
+
+mapped
+ 'mapped' printNL
+!
+
+unmapped
+ 'unmapped' printNL
+!
+
+visibilityChange:how
+ 'visibilityChange:' print. how printNL
! !
!EventMonitor methodsFor:'realization'!
initEvents
- self enableKeyEvents.
self enableButtonEvents.
self enableMotionEvents.
- self enableButtonMotionEvents
+ self enableButtonMotionEvents.
+ self enableKeyReleaseEvents.
+ self enableEvent:#visibilityChange
! !
--- a/FBrowser.st Mon Oct 10 04:15:21 1994 +0100
+++ b/FBrowser.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -11,22 +11,22 @@
"
StandardSystemView subclass:#FileBrowser
- instanceVariableNames:'labelView filterField fileListView subView
- currentDirectory
- fileList
- checkBlock checkDelta timeOfLastCheck
- showLongList showVeryLongList showDotFiles
- myName killButton'
- classVariableNames:'DirectoryHistory HistorySize'
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'labelView filterField fileListView subView
+ currentDirectory
+ fileList
+ checkBlock checkDelta timeOfLastCheck
+ showLongList showVeryLongList showDotFiles
+ myName killButton compressTabs lockUpdate'
+ classVariableNames:'DirectoryHistory HistorySize'
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
FileBrowser comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.16 1994-08-22 18:07:14 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.17 1994-10-10 03:15:41 claus Exp $
'!
!FileBrowser class methodsFor:'documentation'!
@@ -34,7 +34,7 @@
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -47,7 +47,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.16 1994-08-22 18:07:14 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.17 1994-10-10 03:15:41 claus Exp $
"
!
@@ -59,6 +59,18 @@
reading and internationalized strings. A good example for beginners,
on how to do things ....
See additional information in 'doc/misc/fbrowser.doc'.
+
+ instancevariables of interrest:
+
+ checkDelta <Integer> number of seconds of check interval
+ (looks ever so often if shown directory
+ has changed). You may make this number
+ higher, if your network-times are
+ incorrect and thus, the filebrowser
+ checks too often.
+
+ compressTabs <Boolean> if true, leading spaces will be
+ replaced by tabs when saving text
"
! !
@@ -75,73 +87,80 @@
!FileBrowser methodsFor:'initialization'!
initialize
- |frame spacing halfSpacing v topFrame|
+ |frame spacing halfSpacing v cutOff topFrame labelFrame|
super initialize.
+ compressTabs := true.
+ lockUpdate := false.
+
DirectoryHistory isNil ifTrue:[
- DirectoryHistory := OrderedCollection new.
- HistorySize := 15.
+ DirectoryHistory := OrderedCollection new.
+ HistorySize := 15.
].
myName := (resources string:self class name).
self label:myName.
self icon:(Form fromFile:(resources at:'ICON_FILE' default:'FBrowser.xbm')
- resolution:100).
+ resolution:100).
+
+ labelFrame := View origin:(0.0 @ 0.0)
+ corner:(1.0 @ (font height * 2))
+ in:self.
+ StyleSheet name = #st80 ifTrue:[
+ labelFrame level:1
+ ].
spacing := ViewSpacing.
halfSpacing := spacing // 2.
+ StyleSheet is3D ifFalse:[
+ cutOff := halfSpacing
+ ] ifTrue:[
+ cutOff := 0
+ ].
+
checkBlock := [self checkIfDirectoryHasChanged].
- checkDelta := 5.
+ checkDelta := resources at:'CHECK_DELTA' default:10.
currentDirectory := FileDirectory directoryNamed:'.'.
showLongList := resources at:'LONG_LIST' default:false.
showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
- filterField := EditField in:self.
+ filterField := EditField in:labelFrame.
filterField origin:[((width // 4 * 3) + halfSpacing) @ halfSpacing]
- extent:[((width // 4) - borderWidth
- - (filterField margin)
- - halfSpacing
- - filterField borderWidth)
- @
- (filterField heightIncludingBorder "i.e. take its default height"
- "font height + font descent + (filterField margin * 2)"
- )
- ].
+ corner:(1.0 @ filterField heightIncludingBorder).
+ filterField rightInset:ViewSpacing-halfSpacing.
+
self initializeFilterPattern.
filterField leaveAction:[:key | fileListView scrollToTop. self updateCurrentDirectory].
- labelView := Label in:self.
+ labelView := Label in:labelFrame.
labelView origin:(halfSpacing @ halfSpacing)
- extent:[((width // 4 * 3) - spacing - borderWidth)
- @
- (filterField heightIncludingBorder)
- "(font height + font descent)"
- ].
+ extent:[((width // 4 * 3) - spacing - borderWidth)
+ @
+ (filterField heightIncludingBorder)
+ "(font height + font descent)"
+ ].
labelView adjust:#right.
labelView borderWidth:0.
self initializeLabelMiddleButtonMenu.
+ labelFrame middleButtonMenu:(labelView middleButtonMenu).
+
killButton := Button label:(resources string:'kill') in:self.
killButton origin:(halfSpacing @ halfSpacing)
- extent:[(killButton width)
- @
- (filterField heightIncludingBorder)
- ].
+ extent:(killButton width @ filterField height).
killButton hidden:true.
frame := VariableVerticalPanel
- origin:[frame borderWidth negated
- @
- (labelView height + labelView origin y + spacing)
- ]
- extent:[width
- @
- (height - spacing - labelView height - borderWidth)
- ]
- in:self.
+ origin:[frame borderWidth negated
+ @
+ labelFrame height
+ "/ (labelView height + labelView origin y + spacing)
+ ]
+ corner:(1.0 @ 1.0)
+ in:self.
topFrame := ScrollableView for:SelectionInListView in:frame.
topFrame origin:(0.0 @ 0.0) corner:(1.0 @ 0.3).
@@ -149,19 +168,23 @@
fileListView := topFrame scrolledView.
fileListView action:[:lineNr | self fileSelect:lineNr].
fileListView doubleClickAction:[:lineNr | self fileSelect:lineNr.
- self fileGet].
+ self fileGet].
fileListView multipleSelectOk:true.
v := self initializeSubViewIn:frame.
v origin:(0.0 @ 0.3) corner:(1.0 @ 1.0).
subView := v scrolledView.
(subView respondsTo:#directoryForFileDialog:) ifTrue:[
- subView directoryForFileDialog:currentDirectory
+ subView directoryForFileDialog:currentDirectory
].
ObjectMemory addDependent:self.
!
+initEvents
+ self enableEvent:#visibilityChange.
+!
+
initializeFilterPattern
"set an initial matchpattern - can be redefined in subclasses"
@@ -180,7 +203,7 @@
currentDirectory := FileDirectory directoryNamed:aDirectoryPath.
(subView respondsTo:#directoryForFileDialog:) ifTrue:[
- subView directoryForFileDialog:currentDirectory
+ subView directoryForFileDialog:currentDirectory
]
!
@@ -190,52 +213,47 @@
"/ self updateCurrentDirectory
!
-mapped
- super mapped.
- self updateCurrentDirectory
-!
-
initializeLabelMiddleButtonMenu
|labels selectors args|
labelView notNil ifTrue:[
- labels := resources array:#(
- 'copy path'
- '-'
- 'up'
- 'change to home-directory'
- 'change directory ...'
- ).
+ labels := resources array:#(
+ 'copy path'
+ '-'
+ 'up'
+ 'change to home-directory'
+ 'change directory ...'
+ ).
- selectors := #(
- copyPath
- nil
- changeToParentDirectory
- changeToHomeDirectory
- changeCurrentDirectory
- ).
+ selectors := #(
+ copyPath
+ nil
+ changeToParentDirectory
+ changeToHomeDirectory
+ changeCurrentDirectory
+ ).
- args := Array new:5.
+ args := Array new:5.
- DirectoryHistory size > 0 ifTrue:[
- labels := labels copyWith:'-'.
- selectors := selectors copyWith:nil.
- args := args copyWith:nil.
+ DirectoryHistory size > 0 ifTrue:[
+ labels := labels copyWith:'-'.
+ selectors := selectors copyWith:nil.
+ args := args copyWith:nil.
- DirectoryHistory do:[:dirName |
- labels := labels copyWith:dirName.
- selectors := selectors copyWith:#changeDirectoryTo:.
- args := args copyWith:dirName
- ]
- ].
+ DirectoryHistory do:[:dirName |
+ labels := labels copyWith:dirName.
+ selectors := selectors copyWith:#changeDirectoryTo:.
+ args := args copyWith:dirName
+ ]
+ ].
- labelView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:selectors
- args:args
- receiver:self
- for:labelView).
+ labelView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:selectors
+ args:args
+ receiver:self
+ for:labelView).
]
@@ -245,49 +263,74 @@
|labels|
fileListView notNil ifTrue:[
- labels := resources array:#(
- 'spawn'
- 'get contents'
- 'show info'
- 'show full info'
- 'fileIn'
- '-'
- 'update'
- '-'
- 'execute unix command ...'
- '-'
- 'remove'
- 'rename ...'
- '-'
- 'display long list'
- 'show all files'
- '-'
- 'create directory ...'
- 'create file ...').
+ labels := resources array:#(
+ 'spawn'
+ 'get contents'
+ 'show info'
+ 'show full info'
+ 'fileIn'
+ '-'
+ 'update'
+ '-'
+ 'execute unix command ...'
+ '-'
+ 'remove'
+ 'rename ...'
+ '-'
+ 'display long list'
+ 'show all files'
+ '-'
+ 'create directory ...'
+ 'create file ...').
- fileListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(fileSpawn
- fileGet
- fileGetInfo
- fileGetLongInfo
- fileFileIn
- nil
- updateCurrentDirectory
- nil
- fileExecute
- nil
- fileRemove
- fileRename
- nil
- changeDisplayMode
- changeDotFileVisibility
- nil
- newDirectory
- newFile)
- receiver:self
- for:fileListView)
+ fileListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(fileSpawn
+ fileGet
+ fileGetInfo
+ fileGetLongInfo
+ fileFileIn
+ nil
+ updateCurrentDirectory
+ nil
+ fileExecute
+ nil
+ fileRemove
+ fileRename
+ nil
+ changeDisplayMode
+ changeDotFileVisibility
+ nil
+ newDirectory
+ newFile)
+ receiver:self
+ for:fileListView)
+ ]
+! !
+
+!FileBrowser methodsFor:'events'!
+
+mapped
+ super mapped.
+ "
+ whant to know about changed history
+ "
+ DirectoryHistory addDependent:self.
+ self updateCurrentDirectory
+!
+
+visibilityChange:how
+ |wasVisible|
+
+ wasVisible := shown.
+ super visibilityChange:how.
+ (wasVisible not and:[shown]) ifTrue:[
+ "
+ start checking again
+ "
+ Processor removeTimedBlock:checkBlock.
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta.
]
! !
@@ -297,9 +340,9 @@
"show an alertbox, displaying the last Unix-error"
anErrorString isNil ifTrue:[
- self warn:aString withCRs
+ self warn:aString withCRs
] ifFalse:[
- self warn:(aString , '\\(' , anErrorString , ')' ) withCRs
+ self warn:(aString , '\\(' , anErrorString , ')' ) withCRs
]
!
@@ -326,8 +369,8 @@
"tell user, that code has been modified - let her confirm"
(subView modified not or:[subView contentsWasSaved]) ifTrue:[
- aBlock value.
- ^ self
+ aBlock value.
+ ^ self
].
self ask:question yesButton:yesButtonText action:aBlock
!
@@ -340,13 +383,13 @@
newCollection := aCollection species new.
aCollection do:[:fname |
- ((fname startsWith:'.') and:[(fname = '..') not]) ifTrue:[
- showDotFiles ifTrue:[
- newCollection add:fname
- ]
- ] ifFalse:[
- newCollection add:fname
- ]
+ ((fname startsWith:'.') and:[(fname = '..') not]) ifTrue:[
+ showDotFiles ifTrue:[
+ newCollection add:fname
+ ]
+ ] ifFalse:[
+ newCollection add:fname
+ ]
].
^ newCollection
!
@@ -365,7 +408,7 @@
'readme'
"
) do:[:f |
- (currentDirectory isReadable:f) ifTrue:[^ f].
+ (currentDirectory isReadable:f) ifTrue:[^ f].
].
^ nil
!
@@ -374,9 +417,9 @@
"show directory info when dir has changed"
info notNil ifTrue:[
- self show:(self readFile:info)
+ self show:(self readFile:info)
] ifFalse:[
- self show:nil.
+ self show:nil.
]
!
@@ -388,11 +431,11 @@
sel := fileListView selection.
(sel isKindOf:Collection) ifTrue:[
- self onlyOneSelection
+ self onlyOneSelection
] ifFalse:[
- sel notNil ifTrue:[
- ^ fileList at:sel
- ]
+ sel notNil ifTrue:[
+ ^ fileList at:sel
+ ]
].
^ nil
!
@@ -408,29 +451,29 @@
info := currentDirectory infoOf:fileName.
info isNil ifTrue:[
- self showAlert:(resources string:'cannot get info of ''%1'' !!' with:fileName)
- with:(OperatingSystem lastErrorString).
- ^ nil
+ self showAlert:(resources string:'cannot get info of ''%1'' !!' with:fileName)
+ with:(OperatingSystem lastErrorString).
+ ^ nil
].
text := Text new.
type := info at:#type.
(longInfo and:[type == #regular]) ifTrue:[
- fullPath := currentDirectory pathName , '/' , fileName.
- stream := PipeStream readingFrom:('file ' , fullPath).
- stream notNil ifTrue:[
- fileOutput := stream contents asString.
- stream close.
- fileOutput := fileOutput copyFrom:(fileOutput indexOf:$:) + 1.
- fileOutput := fileOutput withoutSeparators
- ]
+ fullPath := currentDirectory pathName , '/' , fileName.
+ stream := PipeStream readingFrom:('file ' , fullPath).
+ stream notNil ifTrue:[
+ fileOutput := stream contents asString.
+ stream close.
+ fileOutput := fileOutput copyFrom:(fileOutput indexOf:$:) + 1.
+ fileOutput := fileOutput withoutSeparators
+ ]
].
s := (resources at:'type: ').
fileOutput isNil ifTrue:[
- s := s , type asString
+ s := s , type asString
] ifFalse:[
- s := s , 'regular (' , fileOutput , ')'
+ s := s , 'regular (' , fileOutput , ')'
].
text add:s.
text add:(resources at:'size: ') , (info at:#size) printString.
@@ -438,25 +481,25 @@
modeBits := (info at:#mode).
modeString := self getModeString:modeBits.
longInfo ifTrue:[
- text add:((resources at:'access: ')
- , modeString
- , ' (' , (modeBits printStringRadix:8), ')' )
+ text add:((resources at:'access: ')
+ , modeString
+ , ' (' , (modeBits printStringRadix:8), ')' )
] ifFalse:[
- text add:(resources at:'access: ') , modeString
+ text add:(resources at:'access: ') , modeString
].
text add:(resources at:'owner: ')
- , (OperatingSystem getUserNameFromID:(info at:#uid)).
+ , (OperatingSystem getUserNameFromID:(info at:#uid)).
longInfo ifTrue:[
text add:(resources at:'group: ')
- , (OperatingSystem getGroupNameFromID:(info at:#gid)).
+ , (OperatingSystem getGroupNameFromID:(info at:#gid)).
text add:(resources at:'last access: ')
- , (info at:#accessTime) asTime printString
- , ' '
- , (info at:#accessTime) asDate printString.
+ , (info at:#accessTime) asTime printString
+ , ' '
+ , (info at:#accessTime) asDate printString.
text add:(resources at:'last modification: ')
- , (info at:#modificationTime) asTime printString
- , ' '
- , (info at:#modificationTime) asDate printString.
+ , (info at:#modificationTime) asTime printString
+ , ' '
+ , (info at:#modificationTime) asDate printString.
].
^ text asString
@@ -473,15 +516,15 @@
#( nil 8r400 8r200 8r100 nil 8r040 8r020 8r010 nil 8r004 8r002 8r001 )
with: texts do:[:bitMask :access |
- bitMask isNil ifTrue:[
- modeString := modeString , (resources string:access)
- ] ifFalse:[
- (bits bitAnd:bitMask) == 0 ifTrue:[
- modeString := modeString copyWith:$-
- ] ifFalse:[
- modeString := modeString copyWith:access
- ]
- ]
+ bitMask isNil ifTrue:[
+ modeString := modeString , (resources string:access)
+ ] ifFalse:[
+ (bits bitAnd:bitMask) == 0 ifTrue:[
+ modeString := modeString copyWith:$-
+ ] ifFalse:[
+ modeString := modeString copyWith:access
+ ]
+ ]
].
^ modeString
!
@@ -491,9 +534,9 @@
This is wrong here - should be moved into OperatingSystem."
^ self getModeString:modeBits
- with:#( 'owner:' $r $w $x
- ' group:' $r $w $x
- ' others:' $r $w $x )
+ with:#( 'owner:' $r $w $x
+ ' group:' $r $w $x
+ ' others:' $r $w $x )
!
checkIfDirectoryHasChanged
@@ -502,41 +545,47 @@
|oldSelection nOld here|
shown ifTrue:[
- currentDirectory notNil ifTrue:[
- here := currentDirectory pathName.
- (OperatingSystem isReadable:here) ifTrue:[
- Processor removeTimedBlock:checkBlock.
+ currentDirectory notNil ifTrue:[
+ lockUpdate ifTrue:[
+ Processor removeTimedBlock:checkBlock.
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta.
+ ^ self
+ ].
+
+ here := currentDirectory pathName.
+ (OperatingSystem isReadable:here) ifTrue:[
+ Processor removeTimedBlock:checkBlock.
- (currentDirectory timeOfLastChange > timeOfLastCheck) ifTrue:[
- nOld := fileListView numberOfSelections.
- oldSelection := fileListView selectionValue.
- self updateCurrentDirectory.
- nOld ~~ 0 ifTrue:[
- nOld > 1 ifTrue:[
- oldSelection do:[:element |
- fileListView addElementToSelection:element
- ]
- ] ifFalse:[
- fileListView selectElement:oldSelection
- ]
- ]
- ] ifFalse:[
- Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
- ] ifFalse:[
- "
- if the directory has been deleted, or is not readable ...
- "
- (OperatingSystem isValidPath:here) ifFalse:[
- self warn:(resources string:'FileBrowser:\\directory %1 is gone ?!!?' with:here) withCRs
- ] ifTrue:[
- self warn:(resources string:'FileBrowser:\\directory %1 is no longer readable ?!!?' with:here) withCRs
- ].
- fileListView contents:nil.
- self label:(myName , ': directory is gone !!').
- "/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
- ]
+ (currentDirectory timeOfLastChange > timeOfLastCheck) ifTrue:[
+ nOld := fileListView numberOfSelections.
+ oldSelection := fileListView selectionValue.
+ self updateCurrentDirectory.
+ nOld ~~ 0 ifTrue:[
+ nOld > 1 ifTrue:[
+ oldSelection do:[:element |
+ fileListView addElementToSelection:element
+ ]
+ ] ifFalse:[
+ fileListView selectElementWithoutScroll:oldSelection
+ ]
+ ]
+ ] ifFalse:[
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ] ifFalse:[
+ "
+ if the directory has been deleted, or is not readable ...
+ "
+ (OperatingSystem isValidPath:here) ifFalse:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is gone ?!!?' with:here) withCRs
+ ] ifTrue:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is no longer readable ?!!?' with:here) withCRs
+ ].
+ fileListView contents:nil.
+ self label:(myName , ': directory is gone !!').
+ "/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ]
]
!
@@ -552,15 +601,15 @@
"
unitString := ''.
size < (500 * 1024) ifTrue:[
- size < (1024) ifTrue:[
- sizeString := size printString
- ] ifFalse:[
- sizeString := (size * 10 // 1024 / 10.0) printString.
- unitString := ' Kb'
- ]
+ size < (1024) ifTrue:[
+ sizeString := size printString
+ ] ifFalse:[
+ sizeString := (size * 10 // 1024 / 10.0) printString.
+ unitString := ' Kb'
+ ]
] ifFalse:[
- sizeString := (size * 10 // 1024 // 1024 / 10.0) printString.
- unitString := ' Mb'
+ sizeString := (size * 10 // 1024 // 1024 / 10.0) printString.
+ unitString := ' Mb'
].
^ (sizeString printStringLeftPaddedTo:5) , unitString.
!
@@ -570,44 +619,41 @@
|files text len line info modeString typ
prevUid prevGid nameString groupString matchPattern
- myProcess myPriority tabSpec|
+ tabSpec|
self withCursor:(Cursor read) do:[
- Processor removeTimedBlock:checkBlock.
-
- labelView label:(currentDirectory pathName).
- timeOfLastCheck := Time now.
-
- files := currentDirectory asOrderedCollection.
+ Processor removeTimedBlock:checkBlock.
- matchPattern := filterField contents.
- (matchPattern notNil and:[
- matchPattern isEmpty not and:[
- matchPattern ~= '*']]) ifTrue:[
- files := files select:[:aName |
- ((currentDirectory typeOf:aName) == #directory)
- or:[matchPattern match:aName]
- ].
- ].
- files sort.
+ labelView label:(currentDirectory pathName).
+ timeOfLastCheck := Time now.
+
+ files := currentDirectory asOrderedCollection.
- files size == 0 ifTrue:[
- self notify:('directory ', currentDirectory pathName, ' vanished').
- ^ self
- ].
- files := self withoutHiddenFiles:files.
+ matchPattern := filterField contents.
+ (matchPattern notNil and:[
+ matchPattern isEmpty not and:[
+ matchPattern ~= '*']]) ifTrue:[
+ files := files select:[:aName |
+ ((currentDirectory typeOf:aName) == #directory)
+ or:[matchPattern match:aName]
+ ].
+ ].
+ files sort.
- "
- this is a time consuming operation (especially, if reading an
- NFS-mounted directory); therefore lower my priority while getting
- the files info ...
- "
- myProcess := Processor activeProcess.
- myPriority := myProcess priority.
- myProcess priority:(Processor userBackgroundPriority).
- [
- fileList := files.
- showLongList ifTrue:[
+ files size == 0 ifTrue:[
+ self notify:('directory ', currentDirectory pathName, ' vanished').
+ ^ self
+ ].
+ files := self withoutHiddenFiles:files.
+
+ "
+ this is a time consuming operation (especially, if reading an
+ NFS-mounted directory); therefore lower my priority while getting
+ the files info ...
+ "
+ Processor activeProcess withLowerPriorityDo:[
+ fileList := files.
+ showLongList ifTrue:[
tabSpec := TabulatorSpecification new.
tabSpec unit:#inch.
@@ -616,100 +662,98 @@
tabSpec align: #(#left #left #left #right #right #decimal).
- text := OrderedCollection new.
- files do:[:aFileName |
+ text := OrderedCollection new.
+ files do:[:aFileName |
|entry|
entry := MultiColListEntry new.
entry tabulatorSpecification:tabSpec.
- "
- if multiple FileBrowsers are reading, let others
- make some progress too
- "
- Processor yield.
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
- len := aFileName size.
- (len < 20) ifTrue:[
- line := aFileName , (String new:(22 - len))
- ] ifFalse:[
- "can happen on BSD only"
- line := (aFileName copyTo:20) , ' '
- ].
+ len := aFileName size.
+ (len < 20) ifTrue:[
+ line := aFileName , (String new:(22 - len))
+ ] ifFalse:[
+ "can happen on BSD only"
+ line := (aFileName copyTo:20) , ' '
+ ].
entry colAt:1 put:line.
- info := currentDirectory infoOf:aFileName.
- info isNil ifTrue:[
- "not accessable - usually a symlink,
- which is not there/not readable
- "
- text add:line , '? bad symbolic link'.
+ info := currentDirectory infoOf:aFileName.
+ info isNil ifTrue:[
+ "not accessable - usually a symlink,
+ which is not there/not readable
+ "
+ text add:line , '? bad symbolic link'.
entry colAt:2 put:'?'.
entry colAt:3 put:'bad symbolic link'.
- ] ifFalse:[
- typ := (info at:#type) at:1.
- (typ == $r) ifFalse:[
- line := line , typ asString , ' '.
+ ] ifFalse:[
+ typ := (info at:#type) at:1.
+ (typ == $r) ifFalse:[
+ line := line , typ asString , ' '.
entry colAt:2 put:typ asString.
- ] ifTrue:[
- line := line , ' '.
+ ] ifTrue:[
+ line := line , ' '.
entry colAt:2 put:' '.
- ].
+ ].
- modeString := self getModeString:(info at:#mode)
- with:#( '' $r $w $x
- ' ' $r $w $x
- ' ' $r $w $x ).
+ modeString := self getModeString:(info at:#mode)
+ with:#( '' $r $w $x
+ ' ' $r $w $x
+ ' ' $r $w $x ).
entry colAt:3 put:modeString.
- line := line , modeString , ' '.
+ line := line , modeString , ' '.
- ((info at:#uid) ~~ prevUid) ifTrue:[
- prevUid := (info at:#uid).
- nameString := OperatingSystem getUserNameFromID:prevUid.
- nameString := nameString , (String new:(10 - nameString size))
- ].
+ ((info at:#uid) ~~ prevUid) ifTrue:[
+ prevUid := (info at:#uid).
+ nameString := OperatingSystem getUserNameFromID:prevUid.
+ nameString := nameString , (String new:(10 - nameString size))
+ ].
entry colAt:4 put:nameString withoutSpaces.
- line := line , nameString.
- ((info at:#gid) ~~ prevGid) ifTrue:[
- prevGid := (info at:#gid).
- groupString := OperatingSystem getGroupNameFromID:prevGid.
- groupString := groupString , (String new:(10 - groupString size))
- ].
+ line := line , nameString.
+ ((info at:#gid) ~~ prevGid) ifTrue:[
+ prevGid := (info at:#gid).
+ groupString := OperatingSystem getGroupNameFromID:prevGid.
+ groupString := groupString , (String new:(10 - groupString size))
+ ].
entry colAt:5 put:groupString withoutSpaces.
- line := line , groupString.
+ line := line , groupString.
- (typ == $r) ifTrue:[
- line := line , (self sizePrintString:(info at:#size)) , ' '.
+ (typ == $r) ifTrue:[
+ line := line , (self sizePrintString:(info at:#size)) , ' '.
entry colAt:6 put:(self sizePrintString:(info at:#size)).
- ].
+ ].
text add:entry
"/ text add:line
- ].
- ].
- ] ifFalse:[
- text := files collect:[:aName |
- "
- if multiple FileBrowsers are reading, let others
- make some progress too
- "
- Processor yield.
- (((currentDirectory typeOf:aName) == #directory) and:[
- (aName ~= '..') and:[aName ~= '.']]) ifTrue:[
- aName , ' ...'
- ] ifFalse:[
- aName
- ]
- ].
- ].
- fileListView setList:text expandTabs:false
- ] valueNowOrOnUnwindDo:[
- myProcess priority:myPriority.
- ].
+ ].
+ ].
+ ] ifFalse:[
+ text := files collect:[:aName |
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
+ (((currentDirectory typeOf:aName) == #directory) and:[
+ (aName ~= '..') and:[aName ~= '.']]) ifTrue:[
+ aName , ' ...'
+ ] ifFalse:[
+ aName
+ ]
+ ].
+ ].
+ fileListView setList:text expandTabs:false
+ ].
- "
- install a new check after some time
- "
- Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ "
+ install a new check after some time
+ "
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
]
!
@@ -721,29 +765,30 @@
self label:myName.
fileName notNil ifTrue:[
- (currentDirectory isDirectory:fileName) ifTrue:[
- (currentDirectory isReadable:fileName) ifTrue:[
- (currentDirectory isExecutable:fileName) ifTrue:[
- updateHistory ifTrue:[
- (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
- DirectoryHistory addFirst:currentDirectory pathName.
- DirectoryHistory size > HistorySize ifTrue:[
- DirectoryHistory removeLast
- ].
- self initializeLabelMiddleButtonMenu
- ]
- ].
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ (currentDirectory isReadable:fileName) ifTrue:[
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ updateHistory ifTrue:[
+ (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
+ DirectoryHistory addFirst:currentDirectory pathName.
+ DirectoryHistory size > HistorySize ifTrue:[
+ DirectoryHistory removeLast
+ ].
+ DirectoryHistory changed.
+"/ self initializeLabelMiddleButtonMenu
+ ]
+ ].
- ^ self setCurrentDirectory:fileName
- ].
- msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
- ] ifFalse:[
- msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
- ]
- ] ifFalse:[
- msg := (resources string:'''%1'' is not a directory !!' with:fileName)
- ].
- self showAlert:msg with:nil
+ ^ self setCurrentDirectory:fileName
+ ].
+ msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
+ ] ifFalse:[
+ msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
+ ]
+ ] ifFalse:[
+ msg := (resources string:'''%1'' is not a directory !!' with:fileName)
+ ].
+ self showAlert:msg with:nil
]
!
@@ -766,21 +811,21 @@
aPathName isEmpty ifTrue:[^ self].
(currentDirectory isDirectory:aPathName) ifTrue:[
- newDirectory := FileDirectory directoryNamed:aPathName in:currentDirectory.
- newDirectory notNil ifTrue:[
- currentDirectory := newDirectory.
- fileListView contents:nil.
- self updateCurrentDirectory.
- info := self getInfoFile.
- self showInfo:info.
- "
- tell my subview (whatever that is) to start its file-dialog
- (i.e. save-as etc.) in that directory
- "
- (subView respondsTo:#directoryForFileDialog:) ifTrue:[
- subView directoryForFileDialog:currentDirectory
- ]
- ]
+ newDirectory := FileDirectory directoryNamed:aPathName in:currentDirectory.
+ newDirectory notNil ifTrue:[
+ currentDirectory := newDirectory.
+ fileListView contents:nil.
+ self updateCurrentDirectory.
+ info := self getInfoFile.
+ self showInfo:info.
+ "
+ tell my subview (whatever that is) to start its file-dialog
+ (i.e. save-as etc.) in that directory
+ "
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ]
+ ]
]
!
@@ -803,14 +848,14 @@
stream := FileStream readonlyFileNamed:fileName in:currentDirectory.
stream isNil ifTrue:[
- msg := (resources string:'cannot read file ''%1'' !!' with:fileName).
- self showAlert:msg with:(FileStream lastErrorString).
- ^ nil
+ msg := (resources string:'cannot read file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString).
+ ^ nil
].
"for very big files, give ObjectMemory a hint, to preallocate more"
(sz := stream size) > 1000000 ifTrue:[
- ObjectMemory moreOldSpace:sz
+ ObjectMemory moreOldSpace:sz
].
text := self readStream:stream lineDelimiter:aCharacter.
@@ -824,13 +869,13 @@
|text msg line|
aCharacter == Character cr ifTrue:[
- text := aStream contents
+ text := aStream contents
] ifFalse:[
- text := Text new.
- [aStream atEnd] whileFalse:[
- line := aStream upTo:aCharacter.
- text add:line
- ].
+ text := Text new.
+ [aStream atEnd] whileFalse:[
+ line := aStream upTo:aCharacter.
+ text add:line
+ ].
].
^ text
!
@@ -839,49 +884,52 @@
|stream msg startNr nLines string|
self withCursor:(Cursor write) do:[
- stream := FileStream newFileNamed:fileName in:currentDirectory.
- stream isNil ifTrue:[
- msg := (resources string:'cannot write file ''%1'' !!' with:fileName).
- self showAlert:msg with:(FileStream lastErrorString)
- ] ifFalse:[
- someText isString ifTrue:[
- stream nextPutAll:someText.
- ] ifFalse:[
- "on some systems, writing linewise is very slow (via NFS)
- therefore we convert to a string and write it in chunks
- to avoid creating huge strings, we do it in blocks of 1000 lines
- "
- startNr := 1.
- nLines := someText size.
- [startNr <= nLines] whileTrue:[
- string := someText asStringFrom:startNr to:((startNr + 1000) min:nLines).
- stream nextPutAll:string.
- startNr := startNr + 1000 + 1.
- ].
+ stream := FileStream newFileNamed:fileName in:currentDirectory.
+ stream isNil ifTrue:[
+ msg := (resources string:'cannot write file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString)
+ ] ifFalse:[
+ someText isString ifTrue:[
+ stream nextPutAll:someText.
+ ] ifFalse:[
+ "
+ on some systems, writing linewise is very slow (via NFS)
+ therefore we convert to a string and write it in chunks
+ to avoid creating huge strings, we do it in blocks of 1000 lines
+ "
+ startNr := 1.
+ nLines := someText size.
+ [startNr <= nLines] whileTrue:[
+ string := someText asStringFrom:startNr
+ to:((startNr + 1000) min:nLines)
+ compressTabs:compressTabs.
+ stream nextPutAll:string.
+ startNr := startNr + 1000 + 1.
+ ].
"/ someText do:[:line |
"/ line notNil ifTrue:[
"/ stream nextPutAll:line.
"/ ].
"/ stream cr.
"/ ]
- ].
- stream close.
- subView modified:false
- ]
+ ].
+ stream close.
+ subView modified:false
+ ]
]
!
doCreateDirectory:newName
(currentDirectory includes:newName) ifTrue:[
- self warn:(resources string:'%1 already exists.' with:newName) withCRs.
- ^ self
+ self warn:'%1 already exists.' with:newName.
+ ^ self
].
(currentDirectory createDirectory:newName) ifTrue:[
- self updateCurrentDirectory
+ self updateCurrentDirectory
] ifFalse:[
- self showAlert:(resources string:'cannot create directory ''%1'' !!' with:newName)
- with:(OperatingSystem lastErrorString)
+ self showAlert:(resources string:'cannot create directory ''%1'' !!' with:newName)
+ with:(OperatingSystem lastErrorString)
]
!
@@ -889,21 +937,21 @@
|aStream box|
(currentDirectory includes:newName) ifTrue:[
- box := YesNoBox new.
- box title:(resources string:'%1 already exists\\truncate ?' with:newName) withCRs.
- box okText:(resources string:'truncate').
- box noText:(resources string:'cancel').
- box noAction:[^ self].
- box showAtPointer
+ box := YesNoBox new.
+ box title:(resources string:'%1 already exists\\truncate ?' with:newName) withCRs.
+ box okText:(resources string:'truncate').
+ box noText:(resources string:'cancel').
+ box noAction:[^ self].
+ box showAtPointer
].
aStream := FileStream newFileNamed:newName in:currentDirectory.
aStream notNil ifTrue:[
- aStream close.
- self updateCurrentDirectory
+ aStream close.
+ self updateCurrentDirectory
] ifFalse:[
- self showAlert:(resources string:'cannot create file ''%1'' !!' with:newName)
- with:(FileStream lastErrorString)
+ self showAlert:(resources string:'cannot create file ''%1'' !!' with:newName)
+ with:(FileStream lastErrorString)
]
!
@@ -913,18 +961,18 @@
|buffer s n i ok convert|
((currentDirectory typeOf:fileName) == #regular) ifFalse:[
- "clicked on something else - ignore it ..."
- self show:(resources string:'''%1'' is not a regular file' with:fileName).
- ^ self
+ "clicked on something else - ignore it ..."
+ self show:(resources string:'''%1'' is not a regular file' with:fileName).
+ ^ self
].
"
check if file is a text file
"
s := FileStream readonlyFileNamed:fileName in:currentDirectory.
s isNil ifTrue:[
- self showAlert:(resources string:'cannot read file ''%1'' !!' with:fileName)
- with:(FileStream lastErrorString).
- ^ nil
+ self showAlert:(resources string:'cannot read file ''%1'' !!' with:fileName)
+ with:(FileStream lastErrorString).
+ ^ nil
].
buffer := String new:300.
@@ -933,28 +981,28 @@
ok := true.
1 to:n do:[:i |
- (buffer at:i) isPrintable ifFalse:[ok := false].
+ (buffer at:i) isPrintable ifFalse:[ok := false].
].
ok ifFalse:[
- (self confirm:(resources string:'''%1'' seems to be a binary file - continue anyway ?' with:fileName))
- ifFalse:[^ self]
+ (self confirm:(resources string:'''%1'' seems to be a binary file - continue anyway ?' with:fileName))
+ ifFalse:[^ self]
].
convert := false.
ok ifTrue:[
- "
- check if line delimiter is a cr
- "
- i := buffer indexOf:Character cr.
- i == 0 ifTrue:[
- "
- no newline found - try cr
- "
- i := buffer indexOf:(Character value:13).
- i ~~ 0 ifTrue:[
- convert := self confirm:(resources string:'''%1'' seems to have CR as line delimiter - convert to NL ?' with:fileName).
- ]
- ]
+ "
+ check if line delimiter is a cr
+ "
+ i := buffer indexOf:Character cr.
+ i == 0 ifTrue:[
+ "
+ no newline found - try cr
+ "
+ i := buffer indexOf:(Character value:13).
+ i ~~ 0 ifTrue:[
+ convert := self confirm:(resources string:'''%1'' seems to have CR as line delimiter - convert to NL ?' with:fileName).
+ ]
+ ]
].
"release old text first - we might need the memory in case of huge files
@@ -962,12 +1010,12 @@
subView contents:nil.
convert ifTrue:[
- self show:(self readFile:fileName lineDelimiter:(Character value:13))
+ self show:(self readFile:fileName lineDelimiter:(Character value:13))
] ifFalse:[
- self show:(self readFile:fileName).
+ self show:(self readFile:fileName).
].
subView acceptAction:[:theCode |
- self writeFile:fileName text:theCode
+ self writeFile:fileName text:theCode
]
!
@@ -985,20 +1033,20 @@
|fileName|
self withCursor:(Cursor read) do:[
- fileName := self getSelectedFileName.
- fileName notNil ifTrue:[
- (currentDirectory isDirectory:fileName) ifTrue:[
- self doChangeCurrentDirectoryTo:fileName updateHistory:true.
- self label:myName
- ] ifFalse:[
- self showFile:fileName.
- (currentDirectory isWritable:fileName) ifFalse:[
- self label:(myName , ': ' , fileName , ' (readonly)')
- ] ifTrue:[
- self label:(myName , ': ' , fileName)
- ]
- ]
- ]
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self doChangeCurrentDirectoryTo:fileName updateHistory:true.
+ self label:myName
+ ] ifFalse:[
+ self showFile:fileName.
+ (currentDirectory isWritable:fileName) ifFalse:[
+ self label:(myName , ': ' , fileName , ' (readonly)')
+ ] ifTrue:[
+ self label:(myName , ': ' , fileName)
+ ]
+ ]
+ ]
]
!
@@ -1026,11 +1074,11 @@
it will make me raise stopSignal when pressed
"
killButton action:[
- stream notNil ifTrue:[
- access critical:[
- myProcess interruptWith:[stopSignal raise].
- ]
- ]
+ stream notNil ifTrue:[
+ access critical:[
+ myProcess interruptWith:[stopSignal raise].
+ ]
+ ]
].
"
start it up under its own windowgroup
@@ -1043,92 +1091,99 @@
self label:(myName , ': executing ' , (command copyTo:(20 min:command size)) , ' ...').
[
self withCursor:(Cursor wait) do:[
- stopSignal catch:[
- startLine := subView cursorLine.
- startCol := subView cursorCol.
+ stopSignal catch:[
+ startLine := subView cursorLine.
+ startCol := subView cursorCol.
- stream := PipeStream readingFrom:('cd '
- , currentDirectory pathName
- , '; '
- , command).
- stream notNil ifTrue:[
- "
- this can be a time consuming operation; therefore lower my priority
- "
- myProcess := Processor activeProcess.
- myPriority := myProcess priority.
- myProcess priority:(Processor userBackgroundPriority).
+ stream := PipeStream readingFrom:('cd '
+ , currentDirectory pathName
+ , '; '
+ , command).
+ stream notNil ifTrue:[
+ "
+ this can be a time consuming operation; therefore lower my priority
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
- [
- replace ifTrue:[
- subView list:nil.
- lnr := 1.
- ].
+ [
+ replace ifTrue:[
+ subView list:nil.
+ lnr := 1.
+ ].
- [stream atEnd] whileFalse:[
- stream readWait.
- line := stream nextLine.
+ [stream atEnd] whileFalse:[
+ (stream readWaitWithTimeout:0.5) ifTrue:[
+ "
+ data available
+ "
+ line := stream nextLine.
- "
- need this critical section; otherwise,
- we could get the signal while waiting for
- an expose event ...
- "
- access critical:[
- line notNil ifTrue:[
- replace ifTrue:[
- subView at:lnr put:line.
- lnr := lnr + 1.
- ] ifFalse:[
- subView insertStringAtCursor:line.
- subView insertCharAtCursor:(Character cr).
- ]
- ].
+ "
+ need this critical section; otherwise,
+ we could get the signal while waiting for
+ an expose event ...
+ "
+ access critical:[
+ line notNil ifTrue:[
+ replace ifTrue:[
+ subView at:lnr put:line.
+ lnr := lnr + 1.
+ ] ifFalse:[
+ subView insertStringAtCursor:line.
+ subView insertCharAtCursor:(Character cr).
+ ]
+ ].
+ ].
+ ].
- windowGroup processExposeEvents.
- ].
- "/
- "/ give others running at same prio a chance too
- "/
- Processor yield
- ].
- ] valueNowOrOnUnwindDo:[
- stream close. stream := nil.
- ].
- self updateCurrentDirectory
- ].
- replace ifTrue:[
- subView modified:false.
- ].
- ]
+ shown ifTrue:[windowGroup processExposeEvents].
+ "
+ give others running at same prio a chance too
+ (especially other FileBrowsers doing the same)
+ "
+ Processor yield
+ ].
+ ] valueNowOrOnUnwindDo:[
+ stream close. stream := nil.
+ ].
+ self updateCurrentDirectory
+ ].
+ replace ifTrue:[
+ subView modified:false.
+ ].
+ ]
]
] valueNowOrOnUnwindDo:[
- |wg|
+ |wg|
- self label:myName.
- myProcess priority:myPriority.
+ self label:myName.
+ myProcess notNil ifTrue:[myProcess priority:myPriority].
- "
- remove the killButton from its group
- (otherwise, it will be destroyed when we shut down the group)
- "
- wg := killButton windowGroup.
- killButton windowGroup:nil.
- "
- shut down the windowgroup
- "
- wg process terminate.
- "
- hide the button, and make sure it will stay
- hidden when we are realized again
- "
- killButton unrealize.
- killButton hidden:true.
- "
- clear its action (actually not needed, but
- releases reference to thisContext earlier)
- "
- killButton action:nil.
+ "
+ remove the killButton from its group
+ (otherwise, it will be destroyed when we shut down the group)
+ "
+ wg := killButton windowGroup.
+ killButton windowGroup:nil.
+ "
+ shut down the windowgroup
+ "
+ wg notNil ifTrue:[
+ wg process terminate.
+ ].
+ "
+ hide the button, and make sure it will stay
+ hidden when we are realized again
+ "
+ killButton unrealize.
+ killButton hidden:true.
+ "
+ clear its action (actually not needed, but
+ releases reference to thisContext earlier)
+ "
+ killButton action:nil.
]
!
@@ -1140,80 +1195,84 @@
((currentDirectory typeOf:fileName) == #regular) ifTrue:[
- (currentDirectory isExecutable:fileName) ifTrue:[
- aBox initialText:(fileName , '<arguments>').
- ^ self
- ].
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ aBox initialText:(fileName , '<arguments>').
+ ^ self
+ ].
- "some heuristics - my personal preferences ...
- (actually this should come from a configfile)"
+ "some heuristics - my personal preferences ...
+ (actually this should come from a configfile)"
- (fileName endsWith:'akefile') ifTrue:[
- aBox initialText:'make target' selectFrom:6 to:11.
- ^ self
- ].
- (fileName endsWith:'.tar.Z') ifTrue:[
- aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
- ^ self
- ].
- (fileName endsWith:'.taz') ifTrue:[
- aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
- ^ self
- ].
- (fileName endsWith:'.tar') ifTrue:[
- aBox initialText:'tar tvf ' , fileName selectFrom:1 to:7.
- ^ self
- ].
- (fileName endsWith:'.zoo') ifTrue:[
- aBox initialText:'zoo -list ' , fileName selectFrom:1 to:9.
- ^ self
- ].
- (fileName endsWith:'.zip') ifTrue:[
- aBox initialText:'unzip -l ' , fileName selectFrom:1 to:8.
- ^ self
- ].
- (fileName endsWith:'.Z') ifTrue:[
- aBox initialText:'uncompress ' , fileName selectFrom:1 to:10.
- ^ self
- ].
- (fileName endsWith:'tar.gz') ifTrue:[
- aBox initialText:('gunzip <' , fileName , ' | tar tvf -' ).
- ^ self
- ].
- (fileName endsWith:'.gz') ifTrue:[
- aBox initialText:('gunzip <' , fileName , ' >' , (fileName copyTo:(fileName size - 3))).
- ^ self
- ].
- (fileName endsWith:'.uue') ifTrue:[
- aBox initialText:'uudecode ' , fileName selectFrom:1 to:8.
- ^ self
- ].
- (fileName endsWith:'.c') ifTrue:[
- aBox initialText:'cc -c ' , fileName selectFrom:1 to:5.
- ^ self
- ].
- (fileName endsWith:'.cc') ifTrue:[
- aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
- ^ self
- ].
- (fileName endsWith:'.C') ifTrue:[
- aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
- ^ self
- ].
- (fileName endsWith:'.xbm') ifTrue:[
- aBox initialText:'bitmap ' , fileName selectFrom:1 to:6.
- ^ self
- ].
- ((fileName endsWith:'.ps') or:[fileName endsWith:'.PS']) ifTrue:[
- aBox initialText:'ghostview ' , fileName selectFrom:1 to:9.
- ^ self
- ].
- ((fileName endsWith:'.1')
- or:[fileName endsWith:'.man']) ifTrue:[
- aBox initialText:'nroff -man ' , fileName selectFrom:1 to:10.
- ^ self
- ].
- aBox initialText:'<cmd> ' , fileName selectFrom:1 to:5
+ (fileName endsWith:'akefile') ifTrue:[
+ aBox initialText:'make target' selectFrom:6 to:11.
+ ^ self
+ ].
+ (fileName endsWith:'.tar.Z') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.taz') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.tar') ifTrue:[
+ aBox initialText:'tar tvf ' , fileName selectFrom:1 to:7.
+ ^ self
+ ].
+ (fileName endsWith:'.zoo') ifTrue:[
+ aBox initialText:'zoo -list ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ (fileName endsWith:'.zip') ifTrue:[
+ aBox initialText:'unzip -l ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.Z') ifTrue:[
+ aBox initialText:'uncompress ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ (fileName endsWith:'tar.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' | tar tvf -' ).
+ ^ self
+ ].
+ (fileName endsWith:'.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' >' , (fileName copyTo:(fileName size - 3))).
+ ^ self
+ ].
+ (fileName endsWith:'.html') ifTrue:[
+ aBox initialText:'chimera ' , fileName .
+ ^ self
+ ].
+ (fileName endsWith:'.uue') ifTrue:[
+ aBox initialText:'uudecode ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.c') ifTrue:[
+ aBox initialText:'cc -c ' , fileName selectFrom:1 to:5.
+ ^ self
+ ].
+ (fileName endsWith:'.cc') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.C') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.xbm') ifTrue:[
+ aBox initialText:'bitmap ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ ((fileName endsWith:'.ps') or:[fileName endsWith:'.PS']) ifTrue:[
+ aBox initialText:'ghostview ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ ((fileName endsWith:'.1')
+ or:[fileName endsWith:'.man']) ifTrue:[
+ aBox initialText:'nroff -man ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ aBox initialText:'<cmd> ' , fileName selectFrom:1 to:5
]
!
@@ -1223,17 +1282,17 @@
|fileName sel box|
- box :=EnterBox new.
+ box := FilenameEnterBox new.
box initialText:''.
sel := fileListView selection.
(sel isKindOf:Collection) ifFalse:[
- sel notNil ifTrue:[
- fileName := fileList at:sel
- ]
+ sel notNil ifTrue:[
+ fileName := fileList at:sel
+ ]
].
fileName notNil ifTrue:[
- self initialCommandFor:fileName into:box.
+ self initialCommandFor:fileName into:box.
].
box title:(resources at:'execute unix command:').
box okText:(resources at:'execute').
@@ -1246,27 +1305,24 @@
sel := fileListView selection.
sel notNil ifTrue:[
- (sel isKindOf:Collection) ifTrue:[
- files := sel collect:[:index | fileList at:index].
- files do:[:aFile |
- aBlock value:aFile
- ]
- ] ifFalse:[
- aBlock value:(fileList at:sel)
- ]
+ (sel isKindOf:Collection) ifTrue:[
+ files := sel collect:[:index | fileList at:index].
+ files do:[:aFile |
+ aBlock value:aFile
+ ]
+ ] ifFalse:[
+ aBlock value:(fileList at:sel)
+ ]
]
!
doRename:oldName to:newName
(oldName notNil and:[newName notNil]) ifTrue:[
- (oldName isBlank or:[newName isBlank]) ifFalse:[
- currentDirectory renameFile:oldName newName:newName.
- self updateCurrentDirectory.
-"
- self checkIfDirectoryHasChanged
-"
- ]
+ (oldName isBlank or:[newName isBlank]) ifFalse:[
+ currentDirectory renameFile:oldName newName:newName.
+ self updateCurrentDirectory.
+ ]
]
!
@@ -1276,30 +1332,36 @@
|ok msg dir|
self withCursor:(Cursor execute) do:[
- self selectedFilesDo:[:fileName |
- (currentDirectory isDirectory:fileName) ifTrue:[
- dir := FileDirectory directoryNamed:fileName in:currentDirectory.
- dir isEmpty ifFalse:[
- self ask:(resources string:'directory ''%1'' is not empty\remove anyway ?' with:fileName)
- yesButton:'remove'
- action:[currentDirectory removeDirectory:fileName]
- ] ifTrue:[
- currentDirectory removeDirectory:fileName
- ].
- ] ifFalse:[
- ok := currentDirectory remove:fileName.
- ok ifFalse:[
- "was not able to remove it"
- msg := (resources string:'cannot remove ''%1'' !!' with:fileName).
- self showAlert:msg with:(OperatingSystem lastErrorString)
- ] ifTrue:[
+ lockUpdate := true.
+ [
+ self selectedFilesDo:[:fileName |
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ dir := FileDirectory directoryNamed:fileName in:currentDirectory.
+ dir isEmpty ifFalse:[
+ self ask:(resources string:'directory ''%1'' is not empty\remove anyway ?' with:fileName)
+ yesButton:'remove'
+ action:[currentDirectory removeDirectory:fileName]
+ ] ifTrue:[
+ currentDirectory removeDirectory:fileName
+ ].
+ ] ifFalse:[
+ ok := currentDirectory remove:fileName.
+ ok ifFalse:[
+ "was not able to remove it"
+ msg := (resources string:'cannot remove ''%1'' !!' with:fileName).
+ self showAlert:msg with:(OperatingSystem lastErrorString)
+ ] ifTrue:[
"
- self show:nil
+ self show:nil
"
- ]
- ]
- ].
- self updateCurrentDirectory.
+ ]
+ ]
+ ].
+ fileListView deselect.
+ self updateCurrentDirectory.
+ ] valueNowOrOnUnwindDo:[
+ lockUpdate := false
+ ]
]
!
@@ -1307,7 +1369,7 @@
"show a warning, that only one file must be selected for
this operation"
- self warn:(resources at:'exactly one file must be selected !!')
+ self warn:'exactly one file must be selected !!'
! !
!FileBrowser methodsFor:'user interaction'!
@@ -1320,13 +1382,13 @@
any := false.
self selectedFilesDo:[:fileName |
- (currentDirectory isDirectory:fileName) ifTrue:[
- self class openOn:(currentDirectory pathName , '/' , fileName).
- any := true
- ]
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self class openOn:(currentDirectory pathName , '/' , fileName).
+ any := true
+ ]
].
any ifFalse:[
- self class openOn:currentDirectory pathName
+ self class openOn:currentDirectory pathName
]
!
@@ -1343,20 +1405,20 @@
|action|
true ifTrue:[
- "
- this replaces everything by the commands output ...
- "
- action := [:command| self doExecuteCommand:command replace:true].
+ "
+ this replaces everything by the commands output ...
+ "
+ action := [:command| self doExecuteCommand:command replace:true].
- self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when command is executed.') withCRs
- yesButton:(resources at:'execute')
- action:[self askForCommandThenDo:action]
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when command is executed.') withCRs
+ yesButton:(resources at:'execute')
+ action:[self askForCommandThenDo:action]
] ifFalse:[
- "
- this inserts the commands output ...
- "
- action := [:command| self doExecuteCommand:command replace:false].
- self askForCommandThenDo:action
+ "
+ this inserts the commands output ...
+ "
+ action := [:command| self doExecuteCommand:command replace:false].
+ self askForCommandThenDo:action
]
!
@@ -1374,14 +1436,14 @@
(subView modified not or:[subView contentsWasSaved]) ifTrue:[^ self doFileGet].
fileName := self getSelectedFileName.
fileName notNil ifTrue:[
- (currentDirectory isDirectory:fileName) ifTrue:[
- msg := (resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.').
- label := 'change'.
- ] ifFalse:[
- msg := (resources at:'contents has not been saved.\\Modifications will be lost when new file is read.').
- label := 'get'.
- ].
- self ask:msg yesButton:label action:[self doFileGet]
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.').
+ label := 'change'.
+ ] ifFalse:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when new file is read.').
+ label := 'get'.
+ ].
+ self ask:msg yesButton:label action:[self doFileGet]
]
!
@@ -1389,26 +1451,26 @@
|fileName inStream printStream line|
self withCursor:(Cursor execute) do:[
- fileName := self getSelectedFileName.
- fileName notNil ifTrue:[
- ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
- inStream := FileStream readonlyFileNamed:fileName
- in:currentDirectory.
- inStream isNil ifFalse:[
- printStream := PrinterStream new.
- printStream notNil ifTrue:[
- [inStream atEnd] whileFalse:[
- line := inStream nextLine.
- printStream nextPutAll:line.
- printStream cr
- ].
- printStream close
- ].
- inStream close
- ]
- ]
- ].
- 0 "compiler hint"
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ inStream := FileStream readonlyFileNamed:fileName
+ in:currentDirectory.
+ inStream isNil ifFalse:[
+ printStream := PrinterStream new.
+ printStream notNil ifTrue:[
+ [inStream atEnd] whileFalse:[
+ line := inStream nextLine.
+ printStream nextPutAll:line.
+ printStream cr
+ ].
+ printStream close
+ ].
+ inStream close
+ ]
+ ]
+ ].
+ 0 "compiler hint"
]
!
@@ -1418,30 +1480,30 @@
|aStream upd|
self withCursor:(Cursor wait) do:[
- self selectedFilesDo:[:fileName |
- ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
- ((fileName endsWith:'.o')
- or:[(fileName endsWith:'.so')
- or:[fileName endsWith:'.obj']]) ifTrue:[
- Object abortSignal catch:[
- ObjectFileLoader loadObjectFile:(currentDirectory pathName , '/' ,fileName)
- ]
- ] ifFalse:[
- aStream := FileStream readonlyFileNamed:fileName in:currentDirectory.
- aStream isNil ifFalse:[
- upd := Class updateChanges:false.
- [
- Smalltalk systemPath addFirst:(currentDirectory pathName).
- aStream fileIn.
- Smalltalk systemPath removeFirst
- ] valueNowOrOnUnwindDo:[
- Class updateChanges:upd.
- aStream close
- ]
- ]
- ]
- ]
- ]
+ self selectedFilesDo:[:fileName |
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ ((fileName endsWith:'.o')
+ or:[(fileName endsWith:'.so')
+ or:[fileName endsWith:'.obj']]) ifTrue:[
+ Object abortSignal catch:[
+ ObjectFileLoader loadObjectFile:(currentDirectory pathName , '/' ,fileName)
+ ]
+ ] ifFalse:[
+ aStream := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ aStream isNil ifFalse:[
+ upd := Class updateChanges:false.
+ [
+ Smalltalk systemPath addFirst:(currentDirectory pathName).
+ aStream fileIn.
+ Smalltalk systemPath removeFirst
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd.
+ aStream close
+ ]
+ ]
+ ]
+ ]
+ ]
]
!
@@ -1455,12 +1517,12 @@
sel := fileListView selection.
sel notNil ifTrue:[
- (sel isKindOf:Collection) ifTrue:[
- q := resources string:'remove selected files ?'
- ] ifFalse:[
- q := resources string:'remove ''%1'' ?' with:(fileList at:sel)
- ].
- self ask:q yesButton:'remove' action:[self doRemove]
+ (sel isKindOf:Collection) ifTrue:[
+ q := resources string:'remove selected files ?'
+ ] ifFalse:[
+ q := resources string:'remove ''%1'' ?' with:(fileList at:sel)
+ ].
+ self ask:q yesButton:'remove' action:[self doRemove]
]
!
@@ -1486,9 +1548,9 @@
queryBox := FilenameEnterBox new.
sel := subView selection.
sel notNil ifTrue:[
- queryBox initialText:(sel asString)
+ queryBox initialText:(sel asString)
] ifFalse:[
- queryBox initialText:''
+ queryBox initialText:''
].
queryBox title:(resources at:'create new file:') withCRs.
queryBox okText:(resources at:'create').
@@ -1506,10 +1568,10 @@
queryBox okText:(resources at:'rename').
"queryBox abortText:(resources at:'abort')."
self selectedFilesDo:[:oldName |
- queryBox title:(resources string:'rename ''%1'' to:' with:oldName).
- queryBox initialText:oldName.
- queryBox action:[:newName | self doRename:oldName to:newName].
- queryBox showAtPointer
+ queryBox title:(resources string:'rename ''%1'' to:' with:oldName).
+ queryBox initialText:oldName.
+ queryBox action:[:newName | self doRename:oldName to:newName].
+ queryBox showAtPointer
]
!
@@ -1517,8 +1579,8 @@
"exit FileBrowser"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when FileBrowser is closed.') withCRs
- yesButton:(resources at:'close')
- action:[self destroy]
+ yesButton:(resources at:'close')
+ action:[self destroy]
!
destroy
@@ -1527,41 +1589,44 @@
ObjectMemory removeDependent:self.
Processor removeTimedBlock:checkBlock.
checkBlock := nil.
+ DirectoryHistory removeDependent:self.
super destroy
!
-update:what
+update:what with:someArgument from:changedObject
(what == #aboutToExit) ifTrue:[
- "system wants to shut down this
- - if text was modified, pop up, and ask user and save if requested."
+ "system wants to shut down this
+ - if text was modified, pop up, and ask user and save if requested."
+
+ (subView modified and:[subView contentsWasSaved not]) ifTrue:[
+ shown ifFalse:[
+ self unrealize.
+ self realize
+ ].
+ self raise.
+ "
+ mhmh: I dont like this - need some way to tell windowGroup to handle
+ all pending exposures ...
+ "
+ self withAllSubViewsDo:[:view | view redraw].
- (subView modified and:[subView contentsWasSaved not]) ifTrue:[
- shown ifFalse:[
- self unrealize.
- self realize
- ].
- self raise.
- "
- mhmh: I dont like this - need some way to tell windowGroup to handle
- all pending exposures ...
- "
- self withAllSubViewsDo:[:view | view redraw].
-
- self ask:(resources at:'FileBrowser:\\contents has not been saved.\\Save before exiting ?') withCRs
- yesButton:'save'
- noButton:'don''t save'
- action:[
- subView acceptAction notNil ifTrue:[
- subView accept
- ] ifFalse:[
- subView save
- ]
- ]
- ].
- ^ self
+ self ask:(resources at:'FileBrowser:\\contents has not been saved.\\Save before exiting ?') withCRs
+ yesButton:'save'
+ noButton:'don''t save'
+ action:[
+ subView acceptAction notNil ifTrue:[
+ subView accept
+ ] ifFalse:[
+ subView save
+ ]
+ ]
+ ].
+ ^ self
].
- super update:what
-
+ changedObject == DirectoryHistory ifTrue:[
+ self initializeLabelMiddleButtonMenu.
+ ^ self
+ ].
!
changeDirectoryTo:aDirectoryName
@@ -1575,8 +1640,8 @@
otherwise change immediately to directory"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
- yesButton:(resources at:'change')
- action:[self queryForDirectoryToChange]
+ yesButton:(resources at:'change')
+ action:[self queryForDirectoryToChange]
!
changeToParentDirectory
@@ -1584,8 +1649,8 @@
otherwise change immediately to directory"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
- yesButton:(resources at:'change')
- action:[self doChangeToParentDirectory]
+ yesButton:(resources at:'change')
+ action:[self doChangeToParentDirectory]
!
changeToHomeDirectory
@@ -1593,8 +1658,8 @@
otherwise change immediately to directory"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
- yesButton:(resources at:'change')
- action:[self doChangeToHomeDirectory]
+ yesButton:(resources at:'change')
+ action:[self doChangeToHomeDirectory]
!
queryForDirectoryToChange
@@ -1618,7 +1683,7 @@
string := self getFileInfoString:longInfo.
string notNil ifTrue:[
- self information:string
+ self information:string
]
!
@@ -1644,9 +1709,9 @@
showLongList := showLongList not.
showLongList ifFalse:[
- fileListView middleButtonMenu labelAt:short put:long
+ fileListView middleButtonMenu labelAt:short put:long
] ifTrue:[
- fileListView middleButtonMenu labelAt:long put:short
+ fileListView middleButtonMenu labelAt:long put:short
].
self updateCurrentDirectory
!
@@ -1661,9 +1726,9 @@
showDotFiles := showDotFiles not.
showDotFiles ifFalse:[
- fileListView middleButtonMenu labelAt:dontShow put:show
+ fileListView middleButtonMenu labelAt:dontShow put:show
] ifTrue:[
- fileListView middleButtonMenu labelAt:show put:dontShow
+ fileListView middleButtonMenu labelAt:show put:dontShow
].
self updateCurrentDirectory
! !
--- a/FileBrowser.st Mon Oct 10 04:15:21 1994 +0100
+++ b/FileBrowser.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -11,22 +11,22 @@
"
StandardSystemView subclass:#FileBrowser
- instanceVariableNames:'labelView filterField fileListView subView
- currentDirectory
- fileList
- checkBlock checkDelta timeOfLastCheck
- showLongList showVeryLongList showDotFiles
- myName killButton'
- classVariableNames:'DirectoryHistory HistorySize'
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'labelView filterField fileListView subView
+ currentDirectory
+ fileList
+ checkBlock checkDelta timeOfLastCheck
+ showLongList showVeryLongList showDotFiles
+ myName killButton compressTabs lockUpdate'
+ classVariableNames:'DirectoryHistory HistorySize'
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
FileBrowser comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.16 1994-08-22 18:07:14 claus Exp $
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.17 1994-10-10 03:15:41 claus Exp $
'!
!FileBrowser class methodsFor:'documentation'!
@@ -34,7 +34,7 @@
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -47,7 +47,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.16 1994-08-22 18:07:14 claus Exp $
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.17 1994-10-10 03:15:41 claus Exp $
"
!
@@ -59,6 +59,18 @@
reading and internationalized strings. A good example for beginners,
on how to do things ....
See additional information in 'doc/misc/fbrowser.doc'.
+
+ instancevariables of interrest:
+
+ checkDelta <Integer> number of seconds of check interval
+ (looks ever so often if shown directory
+ has changed). You may make this number
+ higher, if your network-times are
+ incorrect and thus, the filebrowser
+ checks too often.
+
+ compressTabs <Boolean> if true, leading spaces will be
+ replaced by tabs when saving text
"
! !
@@ -75,73 +87,80 @@
!FileBrowser methodsFor:'initialization'!
initialize
- |frame spacing halfSpacing v topFrame|
+ |frame spacing halfSpacing v cutOff topFrame labelFrame|
super initialize.
+ compressTabs := true.
+ lockUpdate := false.
+
DirectoryHistory isNil ifTrue:[
- DirectoryHistory := OrderedCollection new.
- HistorySize := 15.
+ DirectoryHistory := OrderedCollection new.
+ HistorySize := 15.
].
myName := (resources string:self class name).
self label:myName.
self icon:(Form fromFile:(resources at:'ICON_FILE' default:'FBrowser.xbm')
- resolution:100).
+ resolution:100).
+
+ labelFrame := View origin:(0.0 @ 0.0)
+ corner:(1.0 @ (font height * 2))
+ in:self.
+ StyleSheet name = #st80 ifTrue:[
+ labelFrame level:1
+ ].
spacing := ViewSpacing.
halfSpacing := spacing // 2.
+ StyleSheet is3D ifFalse:[
+ cutOff := halfSpacing
+ ] ifTrue:[
+ cutOff := 0
+ ].
+
checkBlock := [self checkIfDirectoryHasChanged].
- checkDelta := 5.
+ checkDelta := resources at:'CHECK_DELTA' default:10.
currentDirectory := FileDirectory directoryNamed:'.'.
showLongList := resources at:'LONG_LIST' default:false.
showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
- filterField := EditField in:self.
+ filterField := EditField in:labelFrame.
filterField origin:[((width // 4 * 3) + halfSpacing) @ halfSpacing]
- extent:[((width // 4) - borderWidth
- - (filterField margin)
- - halfSpacing
- - filterField borderWidth)
- @
- (filterField heightIncludingBorder "i.e. take its default height"
- "font height + font descent + (filterField margin * 2)"
- )
- ].
+ corner:(1.0 @ filterField heightIncludingBorder).
+ filterField rightInset:ViewSpacing-halfSpacing.
+
self initializeFilterPattern.
filterField leaveAction:[:key | fileListView scrollToTop. self updateCurrentDirectory].
- labelView := Label in:self.
+ labelView := Label in:labelFrame.
labelView origin:(halfSpacing @ halfSpacing)
- extent:[((width // 4 * 3) - spacing - borderWidth)
- @
- (filterField heightIncludingBorder)
- "(font height + font descent)"
- ].
+ extent:[((width // 4 * 3) - spacing - borderWidth)
+ @
+ (filterField heightIncludingBorder)
+ "(font height + font descent)"
+ ].
labelView adjust:#right.
labelView borderWidth:0.
self initializeLabelMiddleButtonMenu.
+ labelFrame middleButtonMenu:(labelView middleButtonMenu).
+
killButton := Button label:(resources string:'kill') in:self.
killButton origin:(halfSpacing @ halfSpacing)
- extent:[(killButton width)
- @
- (filterField heightIncludingBorder)
- ].
+ extent:(killButton width @ filterField height).
killButton hidden:true.
frame := VariableVerticalPanel
- origin:[frame borderWidth negated
- @
- (labelView height + labelView origin y + spacing)
- ]
- extent:[width
- @
- (height - spacing - labelView height - borderWidth)
- ]
- in:self.
+ origin:[frame borderWidth negated
+ @
+ labelFrame height
+ "/ (labelView height + labelView origin y + spacing)
+ ]
+ corner:(1.0 @ 1.0)
+ in:self.
topFrame := ScrollableView for:SelectionInListView in:frame.
topFrame origin:(0.0 @ 0.0) corner:(1.0 @ 0.3).
@@ -149,19 +168,23 @@
fileListView := topFrame scrolledView.
fileListView action:[:lineNr | self fileSelect:lineNr].
fileListView doubleClickAction:[:lineNr | self fileSelect:lineNr.
- self fileGet].
+ self fileGet].
fileListView multipleSelectOk:true.
v := self initializeSubViewIn:frame.
v origin:(0.0 @ 0.3) corner:(1.0 @ 1.0).
subView := v scrolledView.
(subView respondsTo:#directoryForFileDialog:) ifTrue:[
- subView directoryForFileDialog:currentDirectory
+ subView directoryForFileDialog:currentDirectory
].
ObjectMemory addDependent:self.
!
+initEvents
+ self enableEvent:#visibilityChange.
+!
+
initializeFilterPattern
"set an initial matchpattern - can be redefined in subclasses"
@@ -180,7 +203,7 @@
currentDirectory := FileDirectory directoryNamed:aDirectoryPath.
(subView respondsTo:#directoryForFileDialog:) ifTrue:[
- subView directoryForFileDialog:currentDirectory
+ subView directoryForFileDialog:currentDirectory
]
!
@@ -190,52 +213,47 @@
"/ self updateCurrentDirectory
!
-mapped
- super mapped.
- self updateCurrentDirectory
-!
-
initializeLabelMiddleButtonMenu
|labels selectors args|
labelView notNil ifTrue:[
- labels := resources array:#(
- 'copy path'
- '-'
- 'up'
- 'change to home-directory'
- 'change directory ...'
- ).
+ labels := resources array:#(
+ 'copy path'
+ '-'
+ 'up'
+ 'change to home-directory'
+ 'change directory ...'
+ ).
- selectors := #(
- copyPath
- nil
- changeToParentDirectory
- changeToHomeDirectory
- changeCurrentDirectory
- ).
+ selectors := #(
+ copyPath
+ nil
+ changeToParentDirectory
+ changeToHomeDirectory
+ changeCurrentDirectory
+ ).
- args := Array new:5.
+ args := Array new:5.
- DirectoryHistory size > 0 ifTrue:[
- labels := labels copyWith:'-'.
- selectors := selectors copyWith:nil.
- args := args copyWith:nil.
+ DirectoryHistory size > 0 ifTrue:[
+ labels := labels copyWith:'-'.
+ selectors := selectors copyWith:nil.
+ args := args copyWith:nil.
- DirectoryHistory do:[:dirName |
- labels := labels copyWith:dirName.
- selectors := selectors copyWith:#changeDirectoryTo:.
- args := args copyWith:dirName
- ]
- ].
+ DirectoryHistory do:[:dirName |
+ labels := labels copyWith:dirName.
+ selectors := selectors copyWith:#changeDirectoryTo:.
+ args := args copyWith:dirName
+ ]
+ ].
- labelView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:selectors
- args:args
- receiver:self
- for:labelView).
+ labelView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:selectors
+ args:args
+ receiver:self
+ for:labelView).
]
@@ -245,49 +263,74 @@
|labels|
fileListView notNil ifTrue:[
- labels := resources array:#(
- 'spawn'
- 'get contents'
- 'show info'
- 'show full info'
- 'fileIn'
- '-'
- 'update'
- '-'
- 'execute unix command ...'
- '-'
- 'remove'
- 'rename ...'
- '-'
- 'display long list'
- 'show all files'
- '-'
- 'create directory ...'
- 'create file ...').
+ labels := resources array:#(
+ 'spawn'
+ 'get contents'
+ 'show info'
+ 'show full info'
+ 'fileIn'
+ '-'
+ 'update'
+ '-'
+ 'execute unix command ...'
+ '-'
+ 'remove'
+ 'rename ...'
+ '-'
+ 'display long list'
+ 'show all files'
+ '-'
+ 'create directory ...'
+ 'create file ...').
- fileListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(fileSpawn
- fileGet
- fileGetInfo
- fileGetLongInfo
- fileFileIn
- nil
- updateCurrentDirectory
- nil
- fileExecute
- nil
- fileRemove
- fileRename
- nil
- changeDisplayMode
- changeDotFileVisibility
- nil
- newDirectory
- newFile)
- receiver:self
- for:fileListView)
+ fileListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(fileSpawn
+ fileGet
+ fileGetInfo
+ fileGetLongInfo
+ fileFileIn
+ nil
+ updateCurrentDirectory
+ nil
+ fileExecute
+ nil
+ fileRemove
+ fileRename
+ nil
+ changeDisplayMode
+ changeDotFileVisibility
+ nil
+ newDirectory
+ newFile)
+ receiver:self
+ for:fileListView)
+ ]
+! !
+
+!FileBrowser methodsFor:'events'!
+
+mapped
+ super mapped.
+ "
+ whant to know about changed history
+ "
+ DirectoryHistory addDependent:self.
+ self updateCurrentDirectory
+!
+
+visibilityChange:how
+ |wasVisible|
+
+ wasVisible := shown.
+ super visibilityChange:how.
+ (wasVisible not and:[shown]) ifTrue:[
+ "
+ start checking again
+ "
+ Processor removeTimedBlock:checkBlock.
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta.
]
! !
@@ -297,9 +340,9 @@
"show an alertbox, displaying the last Unix-error"
anErrorString isNil ifTrue:[
- self warn:aString withCRs
+ self warn:aString withCRs
] ifFalse:[
- self warn:(aString , '\\(' , anErrorString , ')' ) withCRs
+ self warn:(aString , '\\(' , anErrorString , ')' ) withCRs
]
!
@@ -326,8 +369,8 @@
"tell user, that code has been modified - let her confirm"
(subView modified not or:[subView contentsWasSaved]) ifTrue:[
- aBlock value.
- ^ self
+ aBlock value.
+ ^ self
].
self ask:question yesButton:yesButtonText action:aBlock
!
@@ -340,13 +383,13 @@
newCollection := aCollection species new.
aCollection do:[:fname |
- ((fname startsWith:'.') and:[(fname = '..') not]) ifTrue:[
- showDotFiles ifTrue:[
- newCollection add:fname
- ]
- ] ifFalse:[
- newCollection add:fname
- ]
+ ((fname startsWith:'.') and:[(fname = '..') not]) ifTrue:[
+ showDotFiles ifTrue:[
+ newCollection add:fname
+ ]
+ ] ifFalse:[
+ newCollection add:fname
+ ]
].
^ newCollection
!
@@ -365,7 +408,7 @@
'readme'
"
) do:[:f |
- (currentDirectory isReadable:f) ifTrue:[^ f].
+ (currentDirectory isReadable:f) ifTrue:[^ f].
].
^ nil
!
@@ -374,9 +417,9 @@
"show directory info when dir has changed"
info notNil ifTrue:[
- self show:(self readFile:info)
+ self show:(self readFile:info)
] ifFalse:[
- self show:nil.
+ self show:nil.
]
!
@@ -388,11 +431,11 @@
sel := fileListView selection.
(sel isKindOf:Collection) ifTrue:[
- self onlyOneSelection
+ self onlyOneSelection
] ifFalse:[
- sel notNil ifTrue:[
- ^ fileList at:sel
- ]
+ sel notNil ifTrue:[
+ ^ fileList at:sel
+ ]
].
^ nil
!
@@ -408,29 +451,29 @@
info := currentDirectory infoOf:fileName.
info isNil ifTrue:[
- self showAlert:(resources string:'cannot get info of ''%1'' !!' with:fileName)
- with:(OperatingSystem lastErrorString).
- ^ nil
+ self showAlert:(resources string:'cannot get info of ''%1'' !!' with:fileName)
+ with:(OperatingSystem lastErrorString).
+ ^ nil
].
text := Text new.
type := info at:#type.
(longInfo and:[type == #regular]) ifTrue:[
- fullPath := currentDirectory pathName , '/' , fileName.
- stream := PipeStream readingFrom:('file ' , fullPath).
- stream notNil ifTrue:[
- fileOutput := stream contents asString.
- stream close.
- fileOutput := fileOutput copyFrom:(fileOutput indexOf:$:) + 1.
- fileOutput := fileOutput withoutSeparators
- ]
+ fullPath := currentDirectory pathName , '/' , fileName.
+ stream := PipeStream readingFrom:('file ' , fullPath).
+ stream notNil ifTrue:[
+ fileOutput := stream contents asString.
+ stream close.
+ fileOutput := fileOutput copyFrom:(fileOutput indexOf:$:) + 1.
+ fileOutput := fileOutput withoutSeparators
+ ]
].
s := (resources at:'type: ').
fileOutput isNil ifTrue:[
- s := s , type asString
+ s := s , type asString
] ifFalse:[
- s := s , 'regular (' , fileOutput , ')'
+ s := s , 'regular (' , fileOutput , ')'
].
text add:s.
text add:(resources at:'size: ') , (info at:#size) printString.
@@ -438,25 +481,25 @@
modeBits := (info at:#mode).
modeString := self getModeString:modeBits.
longInfo ifTrue:[
- text add:((resources at:'access: ')
- , modeString
- , ' (' , (modeBits printStringRadix:8), ')' )
+ text add:((resources at:'access: ')
+ , modeString
+ , ' (' , (modeBits printStringRadix:8), ')' )
] ifFalse:[
- text add:(resources at:'access: ') , modeString
+ text add:(resources at:'access: ') , modeString
].
text add:(resources at:'owner: ')
- , (OperatingSystem getUserNameFromID:(info at:#uid)).
+ , (OperatingSystem getUserNameFromID:(info at:#uid)).
longInfo ifTrue:[
text add:(resources at:'group: ')
- , (OperatingSystem getGroupNameFromID:(info at:#gid)).
+ , (OperatingSystem getGroupNameFromID:(info at:#gid)).
text add:(resources at:'last access: ')
- , (info at:#accessTime) asTime printString
- , ' '
- , (info at:#accessTime) asDate printString.
+ , (info at:#accessTime) asTime printString
+ , ' '
+ , (info at:#accessTime) asDate printString.
text add:(resources at:'last modification: ')
- , (info at:#modificationTime) asTime printString
- , ' '
- , (info at:#modificationTime) asDate printString.
+ , (info at:#modificationTime) asTime printString
+ , ' '
+ , (info at:#modificationTime) asDate printString.
].
^ text asString
@@ -473,15 +516,15 @@
#( nil 8r400 8r200 8r100 nil 8r040 8r020 8r010 nil 8r004 8r002 8r001 )
with: texts do:[:bitMask :access |
- bitMask isNil ifTrue:[
- modeString := modeString , (resources string:access)
- ] ifFalse:[
- (bits bitAnd:bitMask) == 0 ifTrue:[
- modeString := modeString copyWith:$-
- ] ifFalse:[
- modeString := modeString copyWith:access
- ]
- ]
+ bitMask isNil ifTrue:[
+ modeString := modeString , (resources string:access)
+ ] ifFalse:[
+ (bits bitAnd:bitMask) == 0 ifTrue:[
+ modeString := modeString copyWith:$-
+ ] ifFalse:[
+ modeString := modeString copyWith:access
+ ]
+ ]
].
^ modeString
!
@@ -491,9 +534,9 @@
This is wrong here - should be moved into OperatingSystem."
^ self getModeString:modeBits
- with:#( 'owner:' $r $w $x
- ' group:' $r $w $x
- ' others:' $r $w $x )
+ with:#( 'owner:' $r $w $x
+ ' group:' $r $w $x
+ ' others:' $r $w $x )
!
checkIfDirectoryHasChanged
@@ -502,41 +545,47 @@
|oldSelection nOld here|
shown ifTrue:[
- currentDirectory notNil ifTrue:[
- here := currentDirectory pathName.
- (OperatingSystem isReadable:here) ifTrue:[
- Processor removeTimedBlock:checkBlock.
+ currentDirectory notNil ifTrue:[
+ lockUpdate ifTrue:[
+ Processor removeTimedBlock:checkBlock.
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta.
+ ^ self
+ ].
+
+ here := currentDirectory pathName.
+ (OperatingSystem isReadable:here) ifTrue:[
+ Processor removeTimedBlock:checkBlock.
- (currentDirectory timeOfLastChange > timeOfLastCheck) ifTrue:[
- nOld := fileListView numberOfSelections.
- oldSelection := fileListView selectionValue.
- self updateCurrentDirectory.
- nOld ~~ 0 ifTrue:[
- nOld > 1 ifTrue:[
- oldSelection do:[:element |
- fileListView addElementToSelection:element
- ]
- ] ifFalse:[
- fileListView selectElement:oldSelection
- ]
- ]
- ] ifFalse:[
- Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
- ] ifFalse:[
- "
- if the directory has been deleted, or is not readable ...
- "
- (OperatingSystem isValidPath:here) ifFalse:[
- self warn:(resources string:'FileBrowser:\\directory %1 is gone ?!!?' with:here) withCRs
- ] ifTrue:[
- self warn:(resources string:'FileBrowser:\\directory %1 is no longer readable ?!!?' with:here) withCRs
- ].
- fileListView contents:nil.
- self label:(myName , ': directory is gone !!').
- "/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
- ]
+ (currentDirectory timeOfLastChange > timeOfLastCheck) ifTrue:[
+ nOld := fileListView numberOfSelections.
+ oldSelection := fileListView selectionValue.
+ self updateCurrentDirectory.
+ nOld ~~ 0 ifTrue:[
+ nOld > 1 ifTrue:[
+ oldSelection do:[:element |
+ fileListView addElementToSelection:element
+ ]
+ ] ifFalse:[
+ fileListView selectElementWithoutScroll:oldSelection
+ ]
+ ]
+ ] ifFalse:[
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ] ifFalse:[
+ "
+ if the directory has been deleted, or is not readable ...
+ "
+ (OperatingSystem isValidPath:here) ifFalse:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is gone ?!!?' with:here) withCRs
+ ] ifTrue:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is no longer readable ?!!?' with:here) withCRs
+ ].
+ fileListView contents:nil.
+ self label:(myName , ': directory is gone !!').
+ "/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ]
]
!
@@ -552,15 +601,15 @@
"
unitString := ''.
size < (500 * 1024) ifTrue:[
- size < (1024) ifTrue:[
- sizeString := size printString
- ] ifFalse:[
- sizeString := (size * 10 // 1024 / 10.0) printString.
- unitString := ' Kb'
- ]
+ size < (1024) ifTrue:[
+ sizeString := size printString
+ ] ifFalse:[
+ sizeString := (size * 10 // 1024 / 10.0) printString.
+ unitString := ' Kb'
+ ]
] ifFalse:[
- sizeString := (size * 10 // 1024 // 1024 / 10.0) printString.
- unitString := ' Mb'
+ sizeString := (size * 10 // 1024 // 1024 / 10.0) printString.
+ unitString := ' Mb'
].
^ (sizeString printStringLeftPaddedTo:5) , unitString.
!
@@ -570,44 +619,41 @@
|files text len line info modeString typ
prevUid prevGid nameString groupString matchPattern
- myProcess myPriority tabSpec|
+ tabSpec|
self withCursor:(Cursor read) do:[
- Processor removeTimedBlock:checkBlock.
-
- labelView label:(currentDirectory pathName).
- timeOfLastCheck := Time now.
-
- files := currentDirectory asOrderedCollection.
+ Processor removeTimedBlock:checkBlock.
- matchPattern := filterField contents.
- (matchPattern notNil and:[
- matchPattern isEmpty not and:[
- matchPattern ~= '*']]) ifTrue:[
- files := files select:[:aName |
- ((currentDirectory typeOf:aName) == #directory)
- or:[matchPattern match:aName]
- ].
- ].
- files sort.
+ labelView label:(currentDirectory pathName).
+ timeOfLastCheck := Time now.
+
+ files := currentDirectory asOrderedCollection.
- files size == 0 ifTrue:[
- self notify:('directory ', currentDirectory pathName, ' vanished').
- ^ self
- ].
- files := self withoutHiddenFiles:files.
+ matchPattern := filterField contents.
+ (matchPattern notNil and:[
+ matchPattern isEmpty not and:[
+ matchPattern ~= '*']]) ifTrue:[
+ files := files select:[:aName |
+ ((currentDirectory typeOf:aName) == #directory)
+ or:[matchPattern match:aName]
+ ].
+ ].
+ files sort.
- "
- this is a time consuming operation (especially, if reading an
- NFS-mounted directory); therefore lower my priority while getting
- the files info ...
- "
- myProcess := Processor activeProcess.
- myPriority := myProcess priority.
- myProcess priority:(Processor userBackgroundPriority).
- [
- fileList := files.
- showLongList ifTrue:[
+ files size == 0 ifTrue:[
+ self notify:('directory ', currentDirectory pathName, ' vanished').
+ ^ self
+ ].
+ files := self withoutHiddenFiles:files.
+
+ "
+ this is a time consuming operation (especially, if reading an
+ NFS-mounted directory); therefore lower my priority while getting
+ the files info ...
+ "
+ Processor activeProcess withLowerPriorityDo:[
+ fileList := files.
+ showLongList ifTrue:[
tabSpec := TabulatorSpecification new.
tabSpec unit:#inch.
@@ -616,100 +662,98 @@
tabSpec align: #(#left #left #left #right #right #decimal).
- text := OrderedCollection new.
- files do:[:aFileName |
+ text := OrderedCollection new.
+ files do:[:aFileName |
|entry|
entry := MultiColListEntry new.
entry tabulatorSpecification:tabSpec.
- "
- if multiple FileBrowsers are reading, let others
- make some progress too
- "
- Processor yield.
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
- len := aFileName size.
- (len < 20) ifTrue:[
- line := aFileName , (String new:(22 - len))
- ] ifFalse:[
- "can happen on BSD only"
- line := (aFileName copyTo:20) , ' '
- ].
+ len := aFileName size.
+ (len < 20) ifTrue:[
+ line := aFileName , (String new:(22 - len))
+ ] ifFalse:[
+ "can happen on BSD only"
+ line := (aFileName copyTo:20) , ' '
+ ].
entry colAt:1 put:line.
- info := currentDirectory infoOf:aFileName.
- info isNil ifTrue:[
- "not accessable - usually a symlink,
- which is not there/not readable
- "
- text add:line , '? bad symbolic link'.
+ info := currentDirectory infoOf:aFileName.
+ info isNil ifTrue:[
+ "not accessable - usually a symlink,
+ which is not there/not readable
+ "
+ text add:line , '? bad symbolic link'.
entry colAt:2 put:'?'.
entry colAt:3 put:'bad symbolic link'.
- ] ifFalse:[
- typ := (info at:#type) at:1.
- (typ == $r) ifFalse:[
- line := line , typ asString , ' '.
+ ] ifFalse:[
+ typ := (info at:#type) at:1.
+ (typ == $r) ifFalse:[
+ line := line , typ asString , ' '.
entry colAt:2 put:typ asString.
- ] ifTrue:[
- line := line , ' '.
+ ] ifTrue:[
+ line := line , ' '.
entry colAt:2 put:' '.
- ].
+ ].
- modeString := self getModeString:(info at:#mode)
- with:#( '' $r $w $x
- ' ' $r $w $x
- ' ' $r $w $x ).
+ modeString := self getModeString:(info at:#mode)
+ with:#( '' $r $w $x
+ ' ' $r $w $x
+ ' ' $r $w $x ).
entry colAt:3 put:modeString.
- line := line , modeString , ' '.
+ line := line , modeString , ' '.
- ((info at:#uid) ~~ prevUid) ifTrue:[
- prevUid := (info at:#uid).
- nameString := OperatingSystem getUserNameFromID:prevUid.
- nameString := nameString , (String new:(10 - nameString size))
- ].
+ ((info at:#uid) ~~ prevUid) ifTrue:[
+ prevUid := (info at:#uid).
+ nameString := OperatingSystem getUserNameFromID:prevUid.
+ nameString := nameString , (String new:(10 - nameString size))
+ ].
entry colAt:4 put:nameString withoutSpaces.
- line := line , nameString.
- ((info at:#gid) ~~ prevGid) ifTrue:[
- prevGid := (info at:#gid).
- groupString := OperatingSystem getGroupNameFromID:prevGid.
- groupString := groupString , (String new:(10 - groupString size))
- ].
+ line := line , nameString.
+ ((info at:#gid) ~~ prevGid) ifTrue:[
+ prevGid := (info at:#gid).
+ groupString := OperatingSystem getGroupNameFromID:prevGid.
+ groupString := groupString , (String new:(10 - groupString size))
+ ].
entry colAt:5 put:groupString withoutSpaces.
- line := line , groupString.
+ line := line , groupString.
- (typ == $r) ifTrue:[
- line := line , (self sizePrintString:(info at:#size)) , ' '.
+ (typ == $r) ifTrue:[
+ line := line , (self sizePrintString:(info at:#size)) , ' '.
entry colAt:6 put:(self sizePrintString:(info at:#size)).
- ].
+ ].
text add:entry
"/ text add:line
- ].
- ].
- ] ifFalse:[
- text := files collect:[:aName |
- "
- if multiple FileBrowsers are reading, let others
- make some progress too
- "
- Processor yield.
- (((currentDirectory typeOf:aName) == #directory) and:[
- (aName ~= '..') and:[aName ~= '.']]) ifTrue:[
- aName , ' ...'
- ] ifFalse:[
- aName
- ]
- ].
- ].
- fileListView setList:text expandTabs:false
- ] valueNowOrOnUnwindDo:[
- myProcess priority:myPriority.
- ].
+ ].
+ ].
+ ] ifFalse:[
+ text := files collect:[:aName |
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
+ (((currentDirectory typeOf:aName) == #directory) and:[
+ (aName ~= '..') and:[aName ~= '.']]) ifTrue:[
+ aName , ' ...'
+ ] ifFalse:[
+ aName
+ ]
+ ].
+ ].
+ fileListView setList:text expandTabs:false
+ ].
- "
- install a new check after some time
- "
- Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ "
+ install a new check after some time
+ "
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
]
!
@@ -721,29 +765,30 @@
self label:myName.
fileName notNil ifTrue:[
- (currentDirectory isDirectory:fileName) ifTrue:[
- (currentDirectory isReadable:fileName) ifTrue:[
- (currentDirectory isExecutable:fileName) ifTrue:[
- updateHistory ifTrue:[
- (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
- DirectoryHistory addFirst:currentDirectory pathName.
- DirectoryHistory size > HistorySize ifTrue:[
- DirectoryHistory removeLast
- ].
- self initializeLabelMiddleButtonMenu
- ]
- ].
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ (currentDirectory isReadable:fileName) ifTrue:[
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ updateHistory ifTrue:[
+ (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
+ DirectoryHistory addFirst:currentDirectory pathName.
+ DirectoryHistory size > HistorySize ifTrue:[
+ DirectoryHistory removeLast
+ ].
+ DirectoryHistory changed.
+"/ self initializeLabelMiddleButtonMenu
+ ]
+ ].
- ^ self setCurrentDirectory:fileName
- ].
- msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
- ] ifFalse:[
- msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
- ]
- ] ifFalse:[
- msg := (resources string:'''%1'' is not a directory !!' with:fileName)
- ].
- self showAlert:msg with:nil
+ ^ self setCurrentDirectory:fileName
+ ].
+ msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
+ ] ifFalse:[
+ msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
+ ]
+ ] ifFalse:[
+ msg := (resources string:'''%1'' is not a directory !!' with:fileName)
+ ].
+ self showAlert:msg with:nil
]
!
@@ -766,21 +811,21 @@
aPathName isEmpty ifTrue:[^ self].
(currentDirectory isDirectory:aPathName) ifTrue:[
- newDirectory := FileDirectory directoryNamed:aPathName in:currentDirectory.
- newDirectory notNil ifTrue:[
- currentDirectory := newDirectory.
- fileListView contents:nil.
- self updateCurrentDirectory.
- info := self getInfoFile.
- self showInfo:info.
- "
- tell my subview (whatever that is) to start its file-dialog
- (i.e. save-as etc.) in that directory
- "
- (subView respondsTo:#directoryForFileDialog:) ifTrue:[
- subView directoryForFileDialog:currentDirectory
- ]
- ]
+ newDirectory := FileDirectory directoryNamed:aPathName in:currentDirectory.
+ newDirectory notNil ifTrue:[
+ currentDirectory := newDirectory.
+ fileListView contents:nil.
+ self updateCurrentDirectory.
+ info := self getInfoFile.
+ self showInfo:info.
+ "
+ tell my subview (whatever that is) to start its file-dialog
+ (i.e. save-as etc.) in that directory
+ "
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ]
+ ]
]
!
@@ -803,14 +848,14 @@
stream := FileStream readonlyFileNamed:fileName in:currentDirectory.
stream isNil ifTrue:[
- msg := (resources string:'cannot read file ''%1'' !!' with:fileName).
- self showAlert:msg with:(FileStream lastErrorString).
- ^ nil
+ msg := (resources string:'cannot read file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString).
+ ^ nil
].
"for very big files, give ObjectMemory a hint, to preallocate more"
(sz := stream size) > 1000000 ifTrue:[
- ObjectMemory moreOldSpace:sz
+ ObjectMemory moreOldSpace:sz
].
text := self readStream:stream lineDelimiter:aCharacter.
@@ -824,13 +869,13 @@
|text msg line|
aCharacter == Character cr ifTrue:[
- text := aStream contents
+ text := aStream contents
] ifFalse:[
- text := Text new.
- [aStream atEnd] whileFalse:[
- line := aStream upTo:aCharacter.
- text add:line
- ].
+ text := Text new.
+ [aStream atEnd] whileFalse:[
+ line := aStream upTo:aCharacter.
+ text add:line
+ ].
].
^ text
!
@@ -839,49 +884,52 @@
|stream msg startNr nLines string|
self withCursor:(Cursor write) do:[
- stream := FileStream newFileNamed:fileName in:currentDirectory.
- stream isNil ifTrue:[
- msg := (resources string:'cannot write file ''%1'' !!' with:fileName).
- self showAlert:msg with:(FileStream lastErrorString)
- ] ifFalse:[
- someText isString ifTrue:[
- stream nextPutAll:someText.
- ] ifFalse:[
- "on some systems, writing linewise is very slow (via NFS)
- therefore we convert to a string and write it in chunks
- to avoid creating huge strings, we do it in blocks of 1000 lines
- "
- startNr := 1.
- nLines := someText size.
- [startNr <= nLines] whileTrue:[
- string := someText asStringFrom:startNr to:((startNr + 1000) min:nLines).
- stream nextPutAll:string.
- startNr := startNr + 1000 + 1.
- ].
+ stream := FileStream newFileNamed:fileName in:currentDirectory.
+ stream isNil ifTrue:[
+ msg := (resources string:'cannot write file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString)
+ ] ifFalse:[
+ someText isString ifTrue:[
+ stream nextPutAll:someText.
+ ] ifFalse:[
+ "
+ on some systems, writing linewise is very slow (via NFS)
+ therefore we convert to a string and write it in chunks
+ to avoid creating huge strings, we do it in blocks of 1000 lines
+ "
+ startNr := 1.
+ nLines := someText size.
+ [startNr <= nLines] whileTrue:[
+ string := someText asStringFrom:startNr
+ to:((startNr + 1000) min:nLines)
+ compressTabs:compressTabs.
+ stream nextPutAll:string.
+ startNr := startNr + 1000 + 1.
+ ].
"/ someText do:[:line |
"/ line notNil ifTrue:[
"/ stream nextPutAll:line.
"/ ].
"/ stream cr.
"/ ]
- ].
- stream close.
- subView modified:false
- ]
+ ].
+ stream close.
+ subView modified:false
+ ]
]
!
doCreateDirectory:newName
(currentDirectory includes:newName) ifTrue:[
- self warn:(resources string:'%1 already exists.' with:newName) withCRs.
- ^ self
+ self warn:'%1 already exists.' with:newName.
+ ^ self
].
(currentDirectory createDirectory:newName) ifTrue:[
- self updateCurrentDirectory
+ self updateCurrentDirectory
] ifFalse:[
- self showAlert:(resources string:'cannot create directory ''%1'' !!' with:newName)
- with:(OperatingSystem lastErrorString)
+ self showAlert:(resources string:'cannot create directory ''%1'' !!' with:newName)
+ with:(OperatingSystem lastErrorString)
]
!
@@ -889,21 +937,21 @@
|aStream box|
(currentDirectory includes:newName) ifTrue:[
- box := YesNoBox new.
- box title:(resources string:'%1 already exists\\truncate ?' with:newName) withCRs.
- box okText:(resources string:'truncate').
- box noText:(resources string:'cancel').
- box noAction:[^ self].
- box showAtPointer
+ box := YesNoBox new.
+ box title:(resources string:'%1 already exists\\truncate ?' with:newName) withCRs.
+ box okText:(resources string:'truncate').
+ box noText:(resources string:'cancel').
+ box noAction:[^ self].
+ box showAtPointer
].
aStream := FileStream newFileNamed:newName in:currentDirectory.
aStream notNil ifTrue:[
- aStream close.
- self updateCurrentDirectory
+ aStream close.
+ self updateCurrentDirectory
] ifFalse:[
- self showAlert:(resources string:'cannot create file ''%1'' !!' with:newName)
- with:(FileStream lastErrorString)
+ self showAlert:(resources string:'cannot create file ''%1'' !!' with:newName)
+ with:(FileStream lastErrorString)
]
!
@@ -913,18 +961,18 @@
|buffer s n i ok convert|
((currentDirectory typeOf:fileName) == #regular) ifFalse:[
- "clicked on something else - ignore it ..."
- self show:(resources string:'''%1'' is not a regular file' with:fileName).
- ^ self
+ "clicked on something else - ignore it ..."
+ self show:(resources string:'''%1'' is not a regular file' with:fileName).
+ ^ self
].
"
check if file is a text file
"
s := FileStream readonlyFileNamed:fileName in:currentDirectory.
s isNil ifTrue:[
- self showAlert:(resources string:'cannot read file ''%1'' !!' with:fileName)
- with:(FileStream lastErrorString).
- ^ nil
+ self showAlert:(resources string:'cannot read file ''%1'' !!' with:fileName)
+ with:(FileStream lastErrorString).
+ ^ nil
].
buffer := String new:300.
@@ -933,28 +981,28 @@
ok := true.
1 to:n do:[:i |
- (buffer at:i) isPrintable ifFalse:[ok := false].
+ (buffer at:i) isPrintable ifFalse:[ok := false].
].
ok ifFalse:[
- (self confirm:(resources string:'''%1'' seems to be a binary file - continue anyway ?' with:fileName))
- ifFalse:[^ self]
+ (self confirm:(resources string:'''%1'' seems to be a binary file - continue anyway ?' with:fileName))
+ ifFalse:[^ self]
].
convert := false.
ok ifTrue:[
- "
- check if line delimiter is a cr
- "
- i := buffer indexOf:Character cr.
- i == 0 ifTrue:[
- "
- no newline found - try cr
- "
- i := buffer indexOf:(Character value:13).
- i ~~ 0 ifTrue:[
- convert := self confirm:(resources string:'''%1'' seems to have CR as line delimiter - convert to NL ?' with:fileName).
- ]
- ]
+ "
+ check if line delimiter is a cr
+ "
+ i := buffer indexOf:Character cr.
+ i == 0 ifTrue:[
+ "
+ no newline found - try cr
+ "
+ i := buffer indexOf:(Character value:13).
+ i ~~ 0 ifTrue:[
+ convert := self confirm:(resources string:'''%1'' seems to have CR as line delimiter - convert to NL ?' with:fileName).
+ ]
+ ]
].
"release old text first - we might need the memory in case of huge files
@@ -962,12 +1010,12 @@
subView contents:nil.
convert ifTrue:[
- self show:(self readFile:fileName lineDelimiter:(Character value:13))
+ self show:(self readFile:fileName lineDelimiter:(Character value:13))
] ifFalse:[
- self show:(self readFile:fileName).
+ self show:(self readFile:fileName).
].
subView acceptAction:[:theCode |
- self writeFile:fileName text:theCode
+ self writeFile:fileName text:theCode
]
!
@@ -985,20 +1033,20 @@
|fileName|
self withCursor:(Cursor read) do:[
- fileName := self getSelectedFileName.
- fileName notNil ifTrue:[
- (currentDirectory isDirectory:fileName) ifTrue:[
- self doChangeCurrentDirectoryTo:fileName updateHistory:true.
- self label:myName
- ] ifFalse:[
- self showFile:fileName.
- (currentDirectory isWritable:fileName) ifFalse:[
- self label:(myName , ': ' , fileName , ' (readonly)')
- ] ifTrue:[
- self label:(myName , ': ' , fileName)
- ]
- ]
- ]
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self doChangeCurrentDirectoryTo:fileName updateHistory:true.
+ self label:myName
+ ] ifFalse:[
+ self showFile:fileName.
+ (currentDirectory isWritable:fileName) ifFalse:[
+ self label:(myName , ': ' , fileName , ' (readonly)')
+ ] ifTrue:[
+ self label:(myName , ': ' , fileName)
+ ]
+ ]
+ ]
]
!
@@ -1026,11 +1074,11 @@
it will make me raise stopSignal when pressed
"
killButton action:[
- stream notNil ifTrue:[
- access critical:[
- myProcess interruptWith:[stopSignal raise].
- ]
- ]
+ stream notNil ifTrue:[
+ access critical:[
+ myProcess interruptWith:[stopSignal raise].
+ ]
+ ]
].
"
start it up under its own windowgroup
@@ -1043,92 +1091,99 @@
self label:(myName , ': executing ' , (command copyTo:(20 min:command size)) , ' ...').
[
self withCursor:(Cursor wait) do:[
- stopSignal catch:[
- startLine := subView cursorLine.
- startCol := subView cursorCol.
+ stopSignal catch:[
+ startLine := subView cursorLine.
+ startCol := subView cursorCol.
- stream := PipeStream readingFrom:('cd '
- , currentDirectory pathName
- , '; '
- , command).
- stream notNil ifTrue:[
- "
- this can be a time consuming operation; therefore lower my priority
- "
- myProcess := Processor activeProcess.
- myPriority := myProcess priority.
- myProcess priority:(Processor userBackgroundPriority).
+ stream := PipeStream readingFrom:('cd '
+ , currentDirectory pathName
+ , '; '
+ , command).
+ stream notNil ifTrue:[
+ "
+ this can be a time consuming operation; therefore lower my priority
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
- [
- replace ifTrue:[
- subView list:nil.
- lnr := 1.
- ].
+ [
+ replace ifTrue:[
+ subView list:nil.
+ lnr := 1.
+ ].
- [stream atEnd] whileFalse:[
- stream readWait.
- line := stream nextLine.
+ [stream atEnd] whileFalse:[
+ (stream readWaitWithTimeout:0.5) ifTrue:[
+ "
+ data available
+ "
+ line := stream nextLine.
- "
- need this critical section; otherwise,
- we could get the signal while waiting for
- an expose event ...
- "
- access critical:[
- line notNil ifTrue:[
- replace ifTrue:[
- subView at:lnr put:line.
- lnr := lnr + 1.
- ] ifFalse:[
- subView insertStringAtCursor:line.
- subView insertCharAtCursor:(Character cr).
- ]
- ].
+ "
+ need this critical section; otherwise,
+ we could get the signal while waiting for
+ an expose event ...
+ "
+ access critical:[
+ line notNil ifTrue:[
+ replace ifTrue:[
+ subView at:lnr put:line.
+ lnr := lnr + 1.
+ ] ifFalse:[
+ subView insertStringAtCursor:line.
+ subView insertCharAtCursor:(Character cr).
+ ]
+ ].
+ ].
+ ].
- windowGroup processExposeEvents.
- ].
- "/
- "/ give others running at same prio a chance too
- "/
- Processor yield
- ].
- ] valueNowOrOnUnwindDo:[
- stream close. stream := nil.
- ].
- self updateCurrentDirectory
- ].
- replace ifTrue:[
- subView modified:false.
- ].
- ]
+ shown ifTrue:[windowGroup processExposeEvents].
+ "
+ give others running at same prio a chance too
+ (especially other FileBrowsers doing the same)
+ "
+ Processor yield
+ ].
+ ] valueNowOrOnUnwindDo:[
+ stream close. stream := nil.
+ ].
+ self updateCurrentDirectory
+ ].
+ replace ifTrue:[
+ subView modified:false.
+ ].
+ ]
]
] valueNowOrOnUnwindDo:[
- |wg|
+ |wg|
- self label:myName.
- myProcess priority:myPriority.
+ self label:myName.
+ myProcess notNil ifTrue:[myProcess priority:myPriority].
- "
- remove the killButton from its group
- (otherwise, it will be destroyed when we shut down the group)
- "
- wg := killButton windowGroup.
- killButton windowGroup:nil.
- "
- shut down the windowgroup
- "
- wg process terminate.
- "
- hide the button, and make sure it will stay
- hidden when we are realized again
- "
- killButton unrealize.
- killButton hidden:true.
- "
- clear its action (actually not needed, but
- releases reference to thisContext earlier)
- "
- killButton action:nil.
+ "
+ remove the killButton from its group
+ (otherwise, it will be destroyed when we shut down the group)
+ "
+ wg := killButton windowGroup.
+ killButton windowGroup:nil.
+ "
+ shut down the windowgroup
+ "
+ wg notNil ifTrue:[
+ wg process terminate.
+ ].
+ "
+ hide the button, and make sure it will stay
+ hidden when we are realized again
+ "
+ killButton unrealize.
+ killButton hidden:true.
+ "
+ clear its action (actually not needed, but
+ releases reference to thisContext earlier)
+ "
+ killButton action:nil.
]
!
@@ -1140,80 +1195,84 @@
((currentDirectory typeOf:fileName) == #regular) ifTrue:[
- (currentDirectory isExecutable:fileName) ifTrue:[
- aBox initialText:(fileName , '<arguments>').
- ^ self
- ].
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ aBox initialText:(fileName , '<arguments>').
+ ^ self
+ ].
- "some heuristics - my personal preferences ...
- (actually this should come from a configfile)"
+ "some heuristics - my personal preferences ...
+ (actually this should come from a configfile)"
- (fileName endsWith:'akefile') ifTrue:[
- aBox initialText:'make target' selectFrom:6 to:11.
- ^ self
- ].
- (fileName endsWith:'.tar.Z') ifTrue:[
- aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
- ^ self
- ].
- (fileName endsWith:'.taz') ifTrue:[
- aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
- ^ self
- ].
- (fileName endsWith:'.tar') ifTrue:[
- aBox initialText:'tar tvf ' , fileName selectFrom:1 to:7.
- ^ self
- ].
- (fileName endsWith:'.zoo') ifTrue:[
- aBox initialText:'zoo -list ' , fileName selectFrom:1 to:9.
- ^ self
- ].
- (fileName endsWith:'.zip') ifTrue:[
- aBox initialText:'unzip -l ' , fileName selectFrom:1 to:8.
- ^ self
- ].
- (fileName endsWith:'.Z') ifTrue:[
- aBox initialText:'uncompress ' , fileName selectFrom:1 to:10.
- ^ self
- ].
- (fileName endsWith:'tar.gz') ifTrue:[
- aBox initialText:('gunzip <' , fileName , ' | tar tvf -' ).
- ^ self
- ].
- (fileName endsWith:'.gz') ifTrue:[
- aBox initialText:('gunzip <' , fileName , ' >' , (fileName copyTo:(fileName size - 3))).
- ^ self
- ].
- (fileName endsWith:'.uue') ifTrue:[
- aBox initialText:'uudecode ' , fileName selectFrom:1 to:8.
- ^ self
- ].
- (fileName endsWith:'.c') ifTrue:[
- aBox initialText:'cc -c ' , fileName selectFrom:1 to:5.
- ^ self
- ].
- (fileName endsWith:'.cc') ifTrue:[
- aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
- ^ self
- ].
- (fileName endsWith:'.C') ifTrue:[
- aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
- ^ self
- ].
- (fileName endsWith:'.xbm') ifTrue:[
- aBox initialText:'bitmap ' , fileName selectFrom:1 to:6.
- ^ self
- ].
- ((fileName endsWith:'.ps') or:[fileName endsWith:'.PS']) ifTrue:[
- aBox initialText:'ghostview ' , fileName selectFrom:1 to:9.
- ^ self
- ].
- ((fileName endsWith:'.1')
- or:[fileName endsWith:'.man']) ifTrue:[
- aBox initialText:'nroff -man ' , fileName selectFrom:1 to:10.
- ^ self
- ].
- aBox initialText:'<cmd> ' , fileName selectFrom:1 to:5
+ (fileName endsWith:'akefile') ifTrue:[
+ aBox initialText:'make target' selectFrom:6 to:11.
+ ^ self
+ ].
+ (fileName endsWith:'.tar.Z') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.taz') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.tar') ifTrue:[
+ aBox initialText:'tar tvf ' , fileName selectFrom:1 to:7.
+ ^ self
+ ].
+ (fileName endsWith:'.zoo') ifTrue:[
+ aBox initialText:'zoo -list ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ (fileName endsWith:'.zip') ifTrue:[
+ aBox initialText:'unzip -l ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.Z') ifTrue:[
+ aBox initialText:'uncompress ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ (fileName endsWith:'tar.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' | tar tvf -' ).
+ ^ self
+ ].
+ (fileName endsWith:'.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' >' , (fileName copyTo:(fileName size - 3))).
+ ^ self
+ ].
+ (fileName endsWith:'.html') ifTrue:[
+ aBox initialText:'chimera ' , fileName .
+ ^ self
+ ].
+ (fileName endsWith:'.uue') ifTrue:[
+ aBox initialText:'uudecode ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.c') ifTrue:[
+ aBox initialText:'cc -c ' , fileName selectFrom:1 to:5.
+ ^ self
+ ].
+ (fileName endsWith:'.cc') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.C') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.xbm') ifTrue:[
+ aBox initialText:'bitmap ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ ((fileName endsWith:'.ps') or:[fileName endsWith:'.PS']) ifTrue:[
+ aBox initialText:'ghostview ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ ((fileName endsWith:'.1')
+ or:[fileName endsWith:'.man']) ifTrue:[
+ aBox initialText:'nroff -man ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ aBox initialText:'<cmd> ' , fileName selectFrom:1 to:5
]
!
@@ -1223,17 +1282,17 @@
|fileName sel box|
- box :=EnterBox new.
+ box := FilenameEnterBox new.
box initialText:''.
sel := fileListView selection.
(sel isKindOf:Collection) ifFalse:[
- sel notNil ifTrue:[
- fileName := fileList at:sel
- ]
+ sel notNil ifTrue:[
+ fileName := fileList at:sel
+ ]
].
fileName notNil ifTrue:[
- self initialCommandFor:fileName into:box.
+ self initialCommandFor:fileName into:box.
].
box title:(resources at:'execute unix command:').
box okText:(resources at:'execute').
@@ -1246,27 +1305,24 @@
sel := fileListView selection.
sel notNil ifTrue:[
- (sel isKindOf:Collection) ifTrue:[
- files := sel collect:[:index | fileList at:index].
- files do:[:aFile |
- aBlock value:aFile
- ]
- ] ifFalse:[
- aBlock value:(fileList at:sel)
- ]
+ (sel isKindOf:Collection) ifTrue:[
+ files := sel collect:[:index | fileList at:index].
+ files do:[:aFile |
+ aBlock value:aFile
+ ]
+ ] ifFalse:[
+ aBlock value:(fileList at:sel)
+ ]
]
!
doRename:oldName to:newName
(oldName notNil and:[newName notNil]) ifTrue:[
- (oldName isBlank or:[newName isBlank]) ifFalse:[
- currentDirectory renameFile:oldName newName:newName.
- self updateCurrentDirectory.
-"
- self checkIfDirectoryHasChanged
-"
- ]
+ (oldName isBlank or:[newName isBlank]) ifFalse:[
+ currentDirectory renameFile:oldName newName:newName.
+ self updateCurrentDirectory.
+ ]
]
!
@@ -1276,30 +1332,36 @@
|ok msg dir|
self withCursor:(Cursor execute) do:[
- self selectedFilesDo:[:fileName |
- (currentDirectory isDirectory:fileName) ifTrue:[
- dir := FileDirectory directoryNamed:fileName in:currentDirectory.
- dir isEmpty ifFalse:[
- self ask:(resources string:'directory ''%1'' is not empty\remove anyway ?' with:fileName)
- yesButton:'remove'
- action:[currentDirectory removeDirectory:fileName]
- ] ifTrue:[
- currentDirectory removeDirectory:fileName
- ].
- ] ifFalse:[
- ok := currentDirectory remove:fileName.
- ok ifFalse:[
- "was not able to remove it"
- msg := (resources string:'cannot remove ''%1'' !!' with:fileName).
- self showAlert:msg with:(OperatingSystem lastErrorString)
- ] ifTrue:[
+ lockUpdate := true.
+ [
+ self selectedFilesDo:[:fileName |
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ dir := FileDirectory directoryNamed:fileName in:currentDirectory.
+ dir isEmpty ifFalse:[
+ self ask:(resources string:'directory ''%1'' is not empty\remove anyway ?' with:fileName)
+ yesButton:'remove'
+ action:[currentDirectory removeDirectory:fileName]
+ ] ifTrue:[
+ currentDirectory removeDirectory:fileName
+ ].
+ ] ifFalse:[
+ ok := currentDirectory remove:fileName.
+ ok ifFalse:[
+ "was not able to remove it"
+ msg := (resources string:'cannot remove ''%1'' !!' with:fileName).
+ self showAlert:msg with:(OperatingSystem lastErrorString)
+ ] ifTrue:[
"
- self show:nil
+ self show:nil
"
- ]
- ]
- ].
- self updateCurrentDirectory.
+ ]
+ ]
+ ].
+ fileListView deselect.
+ self updateCurrentDirectory.
+ ] valueNowOrOnUnwindDo:[
+ lockUpdate := false
+ ]
]
!
@@ -1307,7 +1369,7 @@
"show a warning, that only one file must be selected for
this operation"
- self warn:(resources at:'exactly one file must be selected !!')
+ self warn:'exactly one file must be selected !!'
! !
!FileBrowser methodsFor:'user interaction'!
@@ -1320,13 +1382,13 @@
any := false.
self selectedFilesDo:[:fileName |
- (currentDirectory isDirectory:fileName) ifTrue:[
- self class openOn:(currentDirectory pathName , '/' , fileName).
- any := true
- ]
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self class openOn:(currentDirectory pathName , '/' , fileName).
+ any := true
+ ]
].
any ifFalse:[
- self class openOn:currentDirectory pathName
+ self class openOn:currentDirectory pathName
]
!
@@ -1343,20 +1405,20 @@
|action|
true ifTrue:[
- "
- this replaces everything by the commands output ...
- "
- action := [:command| self doExecuteCommand:command replace:true].
+ "
+ this replaces everything by the commands output ...
+ "
+ action := [:command| self doExecuteCommand:command replace:true].
- self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when command is executed.') withCRs
- yesButton:(resources at:'execute')
- action:[self askForCommandThenDo:action]
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when command is executed.') withCRs
+ yesButton:(resources at:'execute')
+ action:[self askForCommandThenDo:action]
] ifFalse:[
- "
- this inserts the commands output ...
- "
- action := [:command| self doExecuteCommand:command replace:false].
- self askForCommandThenDo:action
+ "
+ this inserts the commands output ...
+ "
+ action := [:command| self doExecuteCommand:command replace:false].
+ self askForCommandThenDo:action
]
!
@@ -1374,14 +1436,14 @@
(subView modified not or:[subView contentsWasSaved]) ifTrue:[^ self doFileGet].
fileName := self getSelectedFileName.
fileName notNil ifTrue:[
- (currentDirectory isDirectory:fileName) ifTrue:[
- msg := (resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.').
- label := 'change'.
- ] ifFalse:[
- msg := (resources at:'contents has not been saved.\\Modifications will be lost when new file is read.').
- label := 'get'.
- ].
- self ask:msg yesButton:label action:[self doFileGet]
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.').
+ label := 'change'.
+ ] ifFalse:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when new file is read.').
+ label := 'get'.
+ ].
+ self ask:msg yesButton:label action:[self doFileGet]
]
!
@@ -1389,26 +1451,26 @@
|fileName inStream printStream line|
self withCursor:(Cursor execute) do:[
- fileName := self getSelectedFileName.
- fileName notNil ifTrue:[
- ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
- inStream := FileStream readonlyFileNamed:fileName
- in:currentDirectory.
- inStream isNil ifFalse:[
- printStream := PrinterStream new.
- printStream notNil ifTrue:[
- [inStream atEnd] whileFalse:[
- line := inStream nextLine.
- printStream nextPutAll:line.
- printStream cr
- ].
- printStream close
- ].
- inStream close
- ]
- ]
- ].
- 0 "compiler hint"
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ inStream := FileStream readonlyFileNamed:fileName
+ in:currentDirectory.
+ inStream isNil ifFalse:[
+ printStream := PrinterStream new.
+ printStream notNil ifTrue:[
+ [inStream atEnd] whileFalse:[
+ line := inStream nextLine.
+ printStream nextPutAll:line.
+ printStream cr
+ ].
+ printStream close
+ ].
+ inStream close
+ ]
+ ]
+ ].
+ 0 "compiler hint"
]
!
@@ -1418,30 +1480,30 @@
|aStream upd|
self withCursor:(Cursor wait) do:[
- self selectedFilesDo:[:fileName |
- ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
- ((fileName endsWith:'.o')
- or:[(fileName endsWith:'.so')
- or:[fileName endsWith:'.obj']]) ifTrue:[
- Object abortSignal catch:[
- ObjectFileLoader loadObjectFile:(currentDirectory pathName , '/' ,fileName)
- ]
- ] ifFalse:[
- aStream := FileStream readonlyFileNamed:fileName in:currentDirectory.
- aStream isNil ifFalse:[
- upd := Class updateChanges:false.
- [
- Smalltalk systemPath addFirst:(currentDirectory pathName).
- aStream fileIn.
- Smalltalk systemPath removeFirst
- ] valueNowOrOnUnwindDo:[
- Class updateChanges:upd.
- aStream close
- ]
- ]
- ]
- ]
- ]
+ self selectedFilesDo:[:fileName |
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ ((fileName endsWith:'.o')
+ or:[(fileName endsWith:'.so')
+ or:[fileName endsWith:'.obj']]) ifTrue:[
+ Object abortSignal catch:[
+ ObjectFileLoader loadObjectFile:(currentDirectory pathName , '/' ,fileName)
+ ]
+ ] ifFalse:[
+ aStream := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ aStream isNil ifFalse:[
+ upd := Class updateChanges:false.
+ [
+ Smalltalk systemPath addFirst:(currentDirectory pathName).
+ aStream fileIn.
+ Smalltalk systemPath removeFirst
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd.
+ aStream close
+ ]
+ ]
+ ]
+ ]
+ ]
]
!
@@ -1455,12 +1517,12 @@
sel := fileListView selection.
sel notNil ifTrue:[
- (sel isKindOf:Collection) ifTrue:[
- q := resources string:'remove selected files ?'
- ] ifFalse:[
- q := resources string:'remove ''%1'' ?' with:(fileList at:sel)
- ].
- self ask:q yesButton:'remove' action:[self doRemove]
+ (sel isKindOf:Collection) ifTrue:[
+ q := resources string:'remove selected files ?'
+ ] ifFalse:[
+ q := resources string:'remove ''%1'' ?' with:(fileList at:sel)
+ ].
+ self ask:q yesButton:'remove' action:[self doRemove]
]
!
@@ -1486,9 +1548,9 @@
queryBox := FilenameEnterBox new.
sel := subView selection.
sel notNil ifTrue:[
- queryBox initialText:(sel asString)
+ queryBox initialText:(sel asString)
] ifFalse:[
- queryBox initialText:''
+ queryBox initialText:''
].
queryBox title:(resources at:'create new file:') withCRs.
queryBox okText:(resources at:'create').
@@ -1506,10 +1568,10 @@
queryBox okText:(resources at:'rename').
"queryBox abortText:(resources at:'abort')."
self selectedFilesDo:[:oldName |
- queryBox title:(resources string:'rename ''%1'' to:' with:oldName).
- queryBox initialText:oldName.
- queryBox action:[:newName | self doRename:oldName to:newName].
- queryBox showAtPointer
+ queryBox title:(resources string:'rename ''%1'' to:' with:oldName).
+ queryBox initialText:oldName.
+ queryBox action:[:newName | self doRename:oldName to:newName].
+ queryBox showAtPointer
]
!
@@ -1517,8 +1579,8 @@
"exit FileBrowser"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when FileBrowser is closed.') withCRs
- yesButton:(resources at:'close')
- action:[self destroy]
+ yesButton:(resources at:'close')
+ action:[self destroy]
!
destroy
@@ -1527,41 +1589,44 @@
ObjectMemory removeDependent:self.
Processor removeTimedBlock:checkBlock.
checkBlock := nil.
+ DirectoryHistory removeDependent:self.
super destroy
!
-update:what
+update:what with:someArgument from:changedObject
(what == #aboutToExit) ifTrue:[
- "system wants to shut down this
- - if text was modified, pop up, and ask user and save if requested."
+ "system wants to shut down this
+ - if text was modified, pop up, and ask user and save if requested."
+
+ (subView modified and:[subView contentsWasSaved not]) ifTrue:[
+ shown ifFalse:[
+ self unrealize.
+ self realize
+ ].
+ self raise.
+ "
+ mhmh: I dont like this - need some way to tell windowGroup to handle
+ all pending exposures ...
+ "
+ self withAllSubViewsDo:[:view | view redraw].
- (subView modified and:[subView contentsWasSaved not]) ifTrue:[
- shown ifFalse:[
- self unrealize.
- self realize
- ].
- self raise.
- "
- mhmh: I dont like this - need some way to tell windowGroup to handle
- all pending exposures ...
- "
- self withAllSubViewsDo:[:view | view redraw].
-
- self ask:(resources at:'FileBrowser:\\contents has not been saved.\\Save before exiting ?') withCRs
- yesButton:'save'
- noButton:'don''t save'
- action:[
- subView acceptAction notNil ifTrue:[
- subView accept
- ] ifFalse:[
- subView save
- ]
- ]
- ].
- ^ self
+ self ask:(resources at:'FileBrowser:\\contents has not been saved.\\Save before exiting ?') withCRs
+ yesButton:'save'
+ noButton:'don''t save'
+ action:[
+ subView acceptAction notNil ifTrue:[
+ subView accept
+ ] ifFalse:[
+ subView save
+ ]
+ ]
+ ].
+ ^ self
].
- super update:what
-
+ changedObject == DirectoryHistory ifTrue:[
+ self initializeLabelMiddleButtonMenu.
+ ^ self
+ ].
!
changeDirectoryTo:aDirectoryName
@@ -1575,8 +1640,8 @@
otherwise change immediately to directory"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
- yesButton:(resources at:'change')
- action:[self queryForDirectoryToChange]
+ yesButton:(resources at:'change')
+ action:[self queryForDirectoryToChange]
!
changeToParentDirectory
@@ -1584,8 +1649,8 @@
otherwise change immediately to directory"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
- yesButton:(resources at:'change')
- action:[self doChangeToParentDirectory]
+ yesButton:(resources at:'change')
+ action:[self doChangeToParentDirectory]
!
changeToHomeDirectory
@@ -1593,8 +1658,8 @@
otherwise change immediately to directory"
self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
- yesButton:(resources at:'change')
- action:[self doChangeToHomeDirectory]
+ yesButton:(resources at:'change')
+ action:[self doChangeToHomeDirectory]
!
queryForDirectoryToChange
@@ -1618,7 +1683,7 @@
string := self getFileInfoString:longInfo.
string notNil ifTrue:[
- self information:string
+ self information:string
]
!
@@ -1644,9 +1709,9 @@
showLongList := showLongList not.
showLongList ifFalse:[
- fileListView middleButtonMenu labelAt:short put:long
+ fileListView middleButtonMenu labelAt:short put:long
] ifTrue:[
- fileListView middleButtonMenu labelAt:long put:short
+ fileListView middleButtonMenu labelAt:long put:short
].
self updateCurrentDirectory
!
@@ -1661,9 +1726,9 @@
showDotFiles := showDotFiles not.
showDotFiles ifFalse:[
- fileListView middleButtonMenu labelAt:dontShow put:show
+ fileListView middleButtonMenu labelAt:dontShow put:show
] ifTrue:[
- fileListView middleButtonMenu labelAt:show put:dontShow
+ fileListView middleButtonMenu labelAt:show put:dontShow
].
self updateCurrentDirectory
! !
--- a/ImageInspectorView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ImageInspectorView.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,19 +13,19 @@
"
InspectorView subclass:#ImageInspectorView
- instanceVariableNames:'imageView'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:'imageView'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
ImageInspectorView comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
this class allows better inspection of images
-$Header: /cvs/stx/stx/libtool/ImageInspectorView.st,v 1.1 1994-08-05 01:38:47 claus Exp $
+$Header: /cvs/stx/stx/libtool/ImageInspectorView.st,v 1.2 1994-10-10 03:15:45 claus Exp $
'!
!ImageInspectorView methodsFor:'accessing'!
@@ -35,23 +35,36 @@
realized ifFalse:[^ self].
imageView image:anObject
- "ImageInspectorView inspect:(Image fromScreen:(0@0 corner:800@800))"
+ "
+ ImageInspectorView inspect:(Image fromScreen:(0@0 corner:800@800))
+ "
! !
!ImageInspectorView methodsFor:'initialization'!
initialize
- |v panel|
+ |v panel newPanel sub|
super initialize.
- panel := subViews first.
- panel corner:(1.0 @ 0.3).
+ newPanel := VariableVerticalPanel in:self.
+ newPanel origin:0.0 @ 0.0 corner:1.0 @ 1.0.
- v := HVScrollableView for:ImageEditView in:self.
+ "
+ wrap my existing subview into the new
+ variable panel
+ "
+ sub := subViews first.
+ self removeSubView:sub.
+ sub origin:0.0@0.0 corner:1.0@0.3.
+ newPanel addSubView:sub.
+
+ v := HVScrollableView for:ImageEditView in:newPanel.
v origin:(0.0 @ 0.3) corner:(1.0 @ 1.0).
imageView := v scrolledView.
- "ImageInspectorView new realize"
- "ImageInspectorView inspect:(Image fromFile:'bitmaps/claus.gif')"
+ "
+ ImageInspectorView new realize
+ ImageInspectorView inspect:(Image fromFile:'bitmaps/claus.gif')
+ "
! !
--- a/ImgInspV.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ImgInspV.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,19 +13,19 @@
"
InspectorView subclass:#ImageInspectorView
- instanceVariableNames:'imageView'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:'imageView'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
ImageInspectorView comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
this class allows better inspection of images
-$Header: /cvs/stx/stx/libtool/Attic/ImgInspV.st,v 1.1 1994-08-05 01:38:47 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ImgInspV.st,v 1.2 1994-10-10 03:15:45 claus Exp $
'!
!ImageInspectorView methodsFor:'accessing'!
@@ -35,23 +35,36 @@
realized ifFalse:[^ self].
imageView image:anObject
- "ImageInspectorView inspect:(Image fromScreen:(0@0 corner:800@800))"
+ "
+ ImageInspectorView inspect:(Image fromScreen:(0@0 corner:800@800))
+ "
! !
!ImageInspectorView methodsFor:'initialization'!
initialize
- |v panel|
+ |v panel newPanel sub|
super initialize.
- panel := subViews first.
- panel corner:(1.0 @ 0.3).
+ newPanel := VariableVerticalPanel in:self.
+ newPanel origin:0.0 @ 0.0 corner:1.0 @ 1.0.
- v := HVScrollableView for:ImageEditView in:self.
+ "
+ wrap my existing subview into the new
+ variable panel
+ "
+ sub := subViews first.
+ self removeSubView:sub.
+ sub origin:0.0@0.0 corner:1.0@0.3.
+ newPanel addSubView:sub.
+
+ v := HVScrollableView for:ImageEditView in:newPanel.
v origin:(0.0 @ 0.3) corner:(1.0 @ 1.0).
imageView := v scrolledView.
- "ImageInspectorView new realize"
- "ImageInspectorView inspect:(Image fromFile:'bitmaps/claus.gif')"
+ "
+ ImageInspectorView new realize
+ ImageInspectorView inspect:(Image fromFile:'bitmaps/claus.gif')
+ "
! !
--- a/InspView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/InspView.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -14,8 +14,8 @@
View subclass:#InspectorView
instanceVariableNames:'listView workspace
- inspectedObject selectedLine
- inspectedValues nShown menu1 menu2'
+ inspectedObject selectedLine
+ inspectedValues nShown menu1 menu2'
classVariableNames:''
poolDictionaries:''
category:'Interface-Inspector'
@@ -23,9 +23,9 @@
InspectorView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.9 1994-08-22 18:07:19 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.10 1994-10-10 03:15:47 claus Exp $
'!
!InspectorView class methodsFor:'documentation'!
@@ -33,7 +33,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -46,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.9 1994-08-22 18:07:19 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.10 1994-10-10 03:15:47 claus Exp $
"
!
@@ -71,13 +71,13 @@
(see OrderedCollectionInspectorView, ImageInspectorView etc. as examples).
examples:
- #(1 2 3 4) asOrderedCollection inspect
- #(1 2 3 4) asOrderedCollection basicInspect
- (Array new:10000) inspect
- (Image fromFile:'bitmaps/claus.gif') inspect
- (Image fromFile:'bitmaps/claus.gif') basicInspect
- (Image fromFile:'bitmaps/SBrowser.xbm') inspect
- (Image fromFile:'bitmaps/SBrowser.xbm') basicInspect
+ #(1 2 3 4) asOrderedCollection inspect
+ #(1 2 3 4) asOrderedCollection basicInspect
+ (Array new:10000) inspect
+ (Image fromFile:'bitmaps/claus.gif') inspect
+ (Image fromFile:'bitmaps/claus.gif') basicInspect
+ (Image fromFile:'bitmaps/SBrowser.xbm') inspect
+ (Image fromFile:'bitmaps/SBrowser.xbm') basicInspect
"
! !
@@ -103,21 +103,21 @@
|topView inspectorView nm|
anObject isClass ifTrue:[
- nm := anObject displayString
+ nm := anObject displayString
] ifFalse:[
- nm := anObject classNameWithArticle
+ nm := anObject classNameWithArticle
].
topView := StandardSystemView
- label:('Inspector on: ' , nm)
- icon:(Form fromFile:'Inspector.xbm' resolution:100)
- minExtent:(100 @ 100).
+ label:('Inspector on: ' , nm)
+ icon:(Form fromFile:'Inspector.xbm' resolution:100)
+ minExtent:(100 @ 100).
topView extent:(Display width // 3) @ (Display height // 3).
inspectorView := self origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:topView.
+ corner:(1.0 @ 1.0)
+ in:topView.
"kludge: must realize first, to be able to set menu again"
topView open.
@@ -138,13 +138,13 @@
super initialize.
panel := VariableHorizontalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
v := HVScrollableView for:SelectionInListView
- miniScrollerH:true
- miniScrollerV:false
- in:panel.
+ miniScrollerH:true
+ miniScrollerV:false
+ in:panel.
v origin:(0.0 @ 0.0) corner:(0.3 @ 1.0).
listView := v scrolledView.
listView action:[:lineNr | self showSelection:lineNr].
@@ -152,9 +152,9 @@
listView ignoreReselect:false.
v := HVScrollableView for:CodeView
- miniScrollerH:true
- miniScrollerV:false
- in:panel.
+ miniScrollerH:true
+ miniScrollerV:false
+ in:panel.
v origin:(0.3 @ 0.0) corner:(1.0 @ 1.0).
workspace := v scrolledView.
nShown := 100.
@@ -163,20 +163,19 @@
initializeListViewMiddleButtonMenus
menu1 := PopUpMenu
- labels:(resources array:#('inspect'))
- selectors:#doInspect
- receiver:self
- for:listView.
+ labels:(resources array:#('inspect'))
+ selectors:#doInspect
+ receiver:self
+ for:listView.
menu2 := PopUpMenu
- labels:(resources array:#(
- 'inspect'
- '-'
- 'show more'
- ))
- selectors:#(doInspect nil showMore)
- receiver:self
- for:listView.
- listView setMiddleButtonMenu:menu1.
+ labels:(resources array:#(
+ 'inspect'
+ '-'
+ 'show more'
+ ))
+ selectors:#(doInspect nil showMore)
+ receiver:self
+ for:listView.
workspace acceptAction:[:theText | self doAccept:theText asString]
!
@@ -203,7 +202,7 @@
"
inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
+ inspectedObject removeDependent:self
].
"
inspectedObject := nil.
@@ -221,30 +220,30 @@
aList add:'self'.
cls := inspectedObject class.
cls isClass ifTrue:[
- cls allInstVarNames do:[:instVarName |
- aList add:instVarName
- ]
+ cls allInstVarNames do:[:instVarName |
+ aList add:instVarName
+ ]
] ifFalse:[
- 1 to:cls instSize do:[:index |
- aList add:('instvar' , index printString)
- ]
+ 1 to:cls instSize do:[:index |
+ aList add:('instvar' , index printString)
+ ]
].
cls isVariable ifTrue:[
- n := inspectedObject basicSize.
- (n > nShown) ifTrue:[
- n := nShown.
- cut := true.
- listView setMiddleButtonMenu:menu2.
- ] ifFalse:[
- cut := false.
- listView setMiddleButtonMenu:menu1.
- ].
- 1 to:n do:[:index |
- aList add:(index printString)
- ].
- cut ifTrue:[
- aList add:' ... '
- ]
+ n := inspectedObject basicSize.
+ (n > nShown) ifTrue:[
+ n := nShown.
+ cut := true.
+ listView setMiddleButtonMenu:menu2.
+ ] ifFalse:[
+ cut := false.
+ listView setMiddleButtonMenu:menu1.
+ ].
+ 1 to:n do:[:index |
+ aList add:(index printString)
+ ].
+ cut ifTrue:[
+ aList add:' ... '
+ ]
].
^ aList
!
@@ -262,37 +261,39 @@
sameObject := anObject == inspectedObject.
"
sameObject ifFalse:[
- inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
- ]
+ inspectedObject notNil ifTrue:[
+ inspectedObject removeDependent:self
+ ]
].
"
inspectedObject := anObject.
+ self initializeListViewMiddleButtonMenus.
+ listView setMiddleButtonMenu:menu1.
realized ifFalse:[^ self].
aList := self listOfNames.
sameObject ifTrue:[
- listView setContents:aList
+ listView setContents:aList
] ifFalse:[
- listView contents:aList
+ listView contents:aList
].
workspace contents:nil.
workspace doItAction:[:theCode |
- inspectedObject class compiler
- evaluate:theCode
- in:nil
- receiver:inspectedObject
- notifying:workspace
- logged:true
- ifFail:nil
+ inspectedObject class compiler
+ evaluate:theCode
+ in:nil
+ receiver:inspectedObject
+ notifying:workspace
+ logged:true
+ ifFail:nil
].
"
sameObject ifFalse:[
- inspectedObject notNil ifTrue:[
- inspectedObject addDependent:self
- ]
+ inspectedObject notNil ifTrue:[
+ inspectedObject addDependent:self
+ ]
].
"
inspectedValues := nil.
@@ -304,13 +305,13 @@
workspace contents:nil.
"
inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
+ inspectedObject removeDependent:self
].
"
inspectedObject := anObject.
"
inspectedObject notNil ifTrue:[
- inspectedObject addDependent:self
+ inspectedObject addDependent:self
].
"
inspectedValues := valueArray.
@@ -322,7 +323,7 @@
workspace contents:nil.
"
inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
+ inspectedObject removeDependent:self
].
"
inspectedObject := nil.
@@ -338,32 +339,32 @@
workspace keyPress:aKey x:0 y:0
!
-update:something
+update:something with:someArgument from:changedObject
"handle updates from other inspectors"
|oldSelection|
- something == inspectedObject ifTrue:[
- oldSelection := listView selection.
- self inspect:inspectedObject.
- oldSelection notNil ifTrue:[
- self showSelection:oldSelection
- ]
+ changedObject == inspectedObject ifTrue:[
+ oldSelection := listView selection.
+ self inspect:inspectedObject.
+ oldSelection notNil ifTrue:[
+ self showSelection:oldSelection
+ ]
]
!
destroy
inspectedObject notNil ifTrue:[
"
- inspectedObject removeDependent:self.
+ inspectedObject removeDependent:self.
"
- inspectedObject := nil
+ inspectedObject := nil
].
menu1 notNil ifTrue:[
- menu1 destroy. menu1 := nil.
+ menu1 destroy. menu1 := nil.
].
menu2 notNil ifTrue:[
- menu2 destroy. menu2 := nil.
+ menu2 destroy. menu2 := nil.
].
inspectedValues := nil.
super destroy
@@ -378,25 +379,25 @@
workspace contents:nil.
"
inspectedValues isNil ifTrue:[
- lineNr == 1 ifTrue:[
- "selecting self also does a re-set, this allows updating the list"
- self inspect:inspectedObject.
- val := inspectedObject
- ] ifFalse:[
- index := lineNr - 1.
- (inspectedObject class isVariable) ifFalse:[
- val := inspectedObject instVarAt:index
- ] ifTrue:[
- index <= (inspectedObject class instSize) ifTrue:[
- val := inspectedObject instVarAt:index
- ] ifFalse:[
- index := index - inspectedObject class instSize.
- val := inspectedObject basicAt:index
- ]
- ]
- ]
+ lineNr == 1 ifTrue:[
+ "selecting self also does a re-set, this allows updating the list"
+ self inspect:inspectedObject.
+ val := inspectedObject
+ ] ifFalse:[
+ index := lineNr - 1.
+ (inspectedObject class isVariable) ifFalse:[
+ val := inspectedObject instVarAt:index
+ ] ifTrue:[
+ index <= (inspectedObject class instSize) ifTrue:[
+ val := inspectedObject instVarAt:index
+ ] ifFalse:[
+ index := index - inspectedObject class instSize.
+ val := inspectedObject basicAt:index
+ ]
+ ]
+ ]
] ifFalse:[
- val := inspectedValues at:lineNr
+ val := inspectedValues at:lineNr
].
string := val displayString.
"
@@ -411,29 +412,29 @@
|value index|
value := inspectedObject class compiler
- evaluate:theText
- receiver:inspectedObject
- notifying:workspace.
+ evaluate:theText
+ receiver:inspectedObject
+ notifying:workspace.
inspectedValues isNil ifTrue:[
- selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- index := selectedLine - 1.
- (inspectedObject class isVariable) ifFalse:[
- inspectedObject instVarAt:index put:value
- ] ifTrue:[
- index <= (inspectedObject class instSize) ifTrue:[
- inspectedObject instVarAt:index put:value
- ] ifFalse:[
- index := index - inspectedObject class instSize.
- inspectedObject basicAt:index put:value
- ]
- ]
- ]
- ]
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ index := selectedLine - 1.
+ (inspectedObject class isVariable) ifFalse:[
+ inspectedObject instVarAt:index put:value
+ ] ifTrue:[
+ index <= (inspectedObject class instSize) ifTrue:[
+ inspectedObject instVarAt:index put:value
+ ] ifFalse:[
+ index := index - inspectedObject class instSize.
+ inspectedObject basicAt:index put:value
+ ]
+ ]
+ ]
+ ]
] ifFalse:[
- selectedLine notNil ifTrue:[
- inspectedValues at:selectedLine put:value
- ]
+ selectedLine notNil ifTrue:[
+ inspectedValues at:selectedLine put:value
+ ]
].
inspectedObject changed
!
@@ -443,25 +444,25 @@
|index objectToInspect|
selectedLine notNil ifTrue:[
- inspectedValues isNil ifTrue:[
- (selectedLine == 1) ifTrue:[
- objectToInspect := inspectedObject
- ] ifFalse:[
- index := selectedLine - 1.
- (inspectedObject class isVariable) ifFalse:[
- objectToInspect := inspectedObject instVarAt:index
- ] ifTrue:[
- index <= (inspectedObject class instSize) ifTrue:[
- objectToInspect := inspectedObject instVarAt:index
- ] ifFalse:[
- index := index - inspectedObject class instSize.
- objectToInspect := inspectedObject basicAt:index
- ]
- ]
- ]
- ] ifFalse:[
- objectToInspect := inspectedValues at:selectedLine ifAbsent:[^ self]
- ].
- objectToInspect inspect
+ inspectedValues isNil ifTrue:[
+ (selectedLine == 1) ifTrue:[
+ objectToInspect := inspectedObject
+ ] ifFalse:[
+ index := selectedLine - 1.
+ (inspectedObject class isVariable) ifFalse:[
+ objectToInspect := inspectedObject instVarAt:index
+ ] ifTrue:[
+ index <= (inspectedObject class instSize) ifTrue:[
+ objectToInspect := inspectedObject instVarAt:index
+ ] ifFalse:[
+ index := index - inspectedObject class instSize.
+ objectToInspect := inspectedObject basicAt:index
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ objectToInspect := inspectedValues at:selectedLine ifAbsent:[^ self]
+ ].
+ objectToInspect inspect
]
! !
--- a/InspectorView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/InspectorView.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -14,8 +14,8 @@
View subclass:#InspectorView
instanceVariableNames:'listView workspace
- inspectedObject selectedLine
- inspectedValues nShown menu1 menu2'
+ inspectedObject selectedLine
+ inspectedValues nShown menu1 menu2'
classVariableNames:''
poolDictionaries:''
category:'Interface-Inspector'
@@ -23,9 +23,9 @@
InspectorView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.9 1994-08-22 18:07:19 claus Exp $
+$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.10 1994-10-10 03:15:47 claus Exp $
'!
!InspectorView class methodsFor:'documentation'!
@@ -33,7 +33,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -46,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.9 1994-08-22 18:07:19 claus Exp $
+$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.10 1994-10-10 03:15:47 claus Exp $
"
!
@@ -71,13 +71,13 @@
(see OrderedCollectionInspectorView, ImageInspectorView etc. as examples).
examples:
- #(1 2 3 4) asOrderedCollection inspect
- #(1 2 3 4) asOrderedCollection basicInspect
- (Array new:10000) inspect
- (Image fromFile:'bitmaps/claus.gif') inspect
- (Image fromFile:'bitmaps/claus.gif') basicInspect
- (Image fromFile:'bitmaps/SBrowser.xbm') inspect
- (Image fromFile:'bitmaps/SBrowser.xbm') basicInspect
+ #(1 2 3 4) asOrderedCollection inspect
+ #(1 2 3 4) asOrderedCollection basicInspect
+ (Array new:10000) inspect
+ (Image fromFile:'bitmaps/claus.gif') inspect
+ (Image fromFile:'bitmaps/claus.gif') basicInspect
+ (Image fromFile:'bitmaps/SBrowser.xbm') inspect
+ (Image fromFile:'bitmaps/SBrowser.xbm') basicInspect
"
! !
@@ -103,21 +103,21 @@
|topView inspectorView nm|
anObject isClass ifTrue:[
- nm := anObject displayString
+ nm := anObject displayString
] ifFalse:[
- nm := anObject classNameWithArticle
+ nm := anObject classNameWithArticle
].
topView := StandardSystemView
- label:('Inspector on: ' , nm)
- icon:(Form fromFile:'Inspector.xbm' resolution:100)
- minExtent:(100 @ 100).
+ label:('Inspector on: ' , nm)
+ icon:(Form fromFile:'Inspector.xbm' resolution:100)
+ minExtent:(100 @ 100).
topView extent:(Display width // 3) @ (Display height // 3).
inspectorView := self origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:topView.
+ corner:(1.0 @ 1.0)
+ in:topView.
"kludge: must realize first, to be able to set menu again"
topView open.
@@ -138,13 +138,13 @@
super initialize.
panel := VariableHorizontalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
v := HVScrollableView for:SelectionInListView
- miniScrollerH:true
- miniScrollerV:false
- in:panel.
+ miniScrollerH:true
+ miniScrollerV:false
+ in:panel.
v origin:(0.0 @ 0.0) corner:(0.3 @ 1.0).
listView := v scrolledView.
listView action:[:lineNr | self showSelection:lineNr].
@@ -152,9 +152,9 @@
listView ignoreReselect:false.
v := HVScrollableView for:CodeView
- miniScrollerH:true
- miniScrollerV:false
- in:panel.
+ miniScrollerH:true
+ miniScrollerV:false
+ in:panel.
v origin:(0.3 @ 0.0) corner:(1.0 @ 1.0).
workspace := v scrolledView.
nShown := 100.
@@ -163,20 +163,19 @@
initializeListViewMiddleButtonMenus
menu1 := PopUpMenu
- labels:(resources array:#('inspect'))
- selectors:#doInspect
- receiver:self
- for:listView.
+ labels:(resources array:#('inspect'))
+ selectors:#doInspect
+ receiver:self
+ for:listView.
menu2 := PopUpMenu
- labels:(resources array:#(
- 'inspect'
- '-'
- 'show more'
- ))
- selectors:#(doInspect nil showMore)
- receiver:self
- for:listView.
- listView setMiddleButtonMenu:menu1.
+ labels:(resources array:#(
+ 'inspect'
+ '-'
+ 'show more'
+ ))
+ selectors:#(doInspect nil showMore)
+ receiver:self
+ for:listView.
workspace acceptAction:[:theText | self doAccept:theText asString]
!
@@ -203,7 +202,7 @@
"
inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
+ inspectedObject removeDependent:self
].
"
inspectedObject := nil.
@@ -221,30 +220,30 @@
aList add:'self'.
cls := inspectedObject class.
cls isClass ifTrue:[
- cls allInstVarNames do:[:instVarName |
- aList add:instVarName
- ]
+ cls allInstVarNames do:[:instVarName |
+ aList add:instVarName
+ ]
] ifFalse:[
- 1 to:cls instSize do:[:index |
- aList add:('instvar' , index printString)
- ]
+ 1 to:cls instSize do:[:index |
+ aList add:('instvar' , index printString)
+ ]
].
cls isVariable ifTrue:[
- n := inspectedObject basicSize.
- (n > nShown) ifTrue:[
- n := nShown.
- cut := true.
- listView setMiddleButtonMenu:menu2.
- ] ifFalse:[
- cut := false.
- listView setMiddleButtonMenu:menu1.
- ].
- 1 to:n do:[:index |
- aList add:(index printString)
- ].
- cut ifTrue:[
- aList add:' ... '
- ]
+ n := inspectedObject basicSize.
+ (n > nShown) ifTrue:[
+ n := nShown.
+ cut := true.
+ listView setMiddleButtonMenu:menu2.
+ ] ifFalse:[
+ cut := false.
+ listView setMiddleButtonMenu:menu1.
+ ].
+ 1 to:n do:[:index |
+ aList add:(index printString)
+ ].
+ cut ifTrue:[
+ aList add:' ... '
+ ]
].
^ aList
!
@@ -262,37 +261,39 @@
sameObject := anObject == inspectedObject.
"
sameObject ifFalse:[
- inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
- ]
+ inspectedObject notNil ifTrue:[
+ inspectedObject removeDependent:self
+ ]
].
"
inspectedObject := anObject.
+ self initializeListViewMiddleButtonMenus.
+ listView setMiddleButtonMenu:menu1.
realized ifFalse:[^ self].
aList := self listOfNames.
sameObject ifTrue:[
- listView setContents:aList
+ listView setContents:aList
] ifFalse:[
- listView contents:aList
+ listView contents:aList
].
workspace contents:nil.
workspace doItAction:[:theCode |
- inspectedObject class compiler
- evaluate:theCode
- in:nil
- receiver:inspectedObject
- notifying:workspace
- logged:true
- ifFail:nil
+ inspectedObject class compiler
+ evaluate:theCode
+ in:nil
+ receiver:inspectedObject
+ notifying:workspace
+ logged:true
+ ifFail:nil
].
"
sameObject ifFalse:[
- inspectedObject notNil ifTrue:[
- inspectedObject addDependent:self
- ]
+ inspectedObject notNil ifTrue:[
+ inspectedObject addDependent:self
+ ]
].
"
inspectedValues := nil.
@@ -304,13 +305,13 @@
workspace contents:nil.
"
inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
+ inspectedObject removeDependent:self
].
"
inspectedObject := anObject.
"
inspectedObject notNil ifTrue:[
- inspectedObject addDependent:self
+ inspectedObject addDependent:self
].
"
inspectedValues := valueArray.
@@ -322,7 +323,7 @@
workspace contents:nil.
"
inspectedObject notNil ifTrue:[
- inspectedObject removeDependent:self
+ inspectedObject removeDependent:self
].
"
inspectedObject := nil.
@@ -338,32 +339,32 @@
workspace keyPress:aKey x:0 y:0
!
-update:something
+update:something with:someArgument from:changedObject
"handle updates from other inspectors"
|oldSelection|
- something == inspectedObject ifTrue:[
- oldSelection := listView selection.
- self inspect:inspectedObject.
- oldSelection notNil ifTrue:[
- self showSelection:oldSelection
- ]
+ changedObject == inspectedObject ifTrue:[
+ oldSelection := listView selection.
+ self inspect:inspectedObject.
+ oldSelection notNil ifTrue:[
+ self showSelection:oldSelection
+ ]
]
!
destroy
inspectedObject notNil ifTrue:[
"
- inspectedObject removeDependent:self.
+ inspectedObject removeDependent:self.
"
- inspectedObject := nil
+ inspectedObject := nil
].
menu1 notNil ifTrue:[
- menu1 destroy. menu1 := nil.
+ menu1 destroy. menu1 := nil.
].
menu2 notNil ifTrue:[
- menu2 destroy. menu2 := nil.
+ menu2 destroy. menu2 := nil.
].
inspectedValues := nil.
super destroy
@@ -378,25 +379,25 @@
workspace contents:nil.
"
inspectedValues isNil ifTrue:[
- lineNr == 1 ifTrue:[
- "selecting self also does a re-set, this allows updating the list"
- self inspect:inspectedObject.
- val := inspectedObject
- ] ifFalse:[
- index := lineNr - 1.
- (inspectedObject class isVariable) ifFalse:[
- val := inspectedObject instVarAt:index
- ] ifTrue:[
- index <= (inspectedObject class instSize) ifTrue:[
- val := inspectedObject instVarAt:index
- ] ifFalse:[
- index := index - inspectedObject class instSize.
- val := inspectedObject basicAt:index
- ]
- ]
- ]
+ lineNr == 1 ifTrue:[
+ "selecting self also does a re-set, this allows updating the list"
+ self inspect:inspectedObject.
+ val := inspectedObject
+ ] ifFalse:[
+ index := lineNr - 1.
+ (inspectedObject class isVariable) ifFalse:[
+ val := inspectedObject instVarAt:index
+ ] ifTrue:[
+ index <= (inspectedObject class instSize) ifTrue:[
+ val := inspectedObject instVarAt:index
+ ] ifFalse:[
+ index := index - inspectedObject class instSize.
+ val := inspectedObject basicAt:index
+ ]
+ ]
+ ]
] ifFalse:[
- val := inspectedValues at:lineNr
+ val := inspectedValues at:lineNr
].
string := val displayString.
"
@@ -411,29 +412,29 @@
|value index|
value := inspectedObject class compiler
- evaluate:theText
- receiver:inspectedObject
- notifying:workspace.
+ evaluate:theText
+ receiver:inspectedObject
+ notifying:workspace.
inspectedValues isNil ifTrue:[
- selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- index := selectedLine - 1.
- (inspectedObject class isVariable) ifFalse:[
- inspectedObject instVarAt:index put:value
- ] ifTrue:[
- index <= (inspectedObject class instSize) ifTrue:[
- inspectedObject instVarAt:index put:value
- ] ifFalse:[
- index := index - inspectedObject class instSize.
- inspectedObject basicAt:index put:value
- ]
- ]
- ]
- ]
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ index := selectedLine - 1.
+ (inspectedObject class isVariable) ifFalse:[
+ inspectedObject instVarAt:index put:value
+ ] ifTrue:[
+ index <= (inspectedObject class instSize) ifTrue:[
+ inspectedObject instVarAt:index put:value
+ ] ifFalse:[
+ index := index - inspectedObject class instSize.
+ inspectedObject basicAt:index put:value
+ ]
+ ]
+ ]
+ ]
] ifFalse:[
- selectedLine notNil ifTrue:[
- inspectedValues at:selectedLine put:value
- ]
+ selectedLine notNil ifTrue:[
+ inspectedValues at:selectedLine put:value
+ ]
].
inspectedObject changed
!
@@ -443,25 +444,25 @@
|index objectToInspect|
selectedLine notNil ifTrue:[
- inspectedValues isNil ifTrue:[
- (selectedLine == 1) ifTrue:[
- objectToInspect := inspectedObject
- ] ifFalse:[
- index := selectedLine - 1.
- (inspectedObject class isVariable) ifFalse:[
- objectToInspect := inspectedObject instVarAt:index
- ] ifTrue:[
- index <= (inspectedObject class instSize) ifTrue:[
- objectToInspect := inspectedObject instVarAt:index
- ] ifFalse:[
- index := index - inspectedObject class instSize.
- objectToInspect := inspectedObject basicAt:index
- ]
- ]
- ]
- ] ifFalse:[
- objectToInspect := inspectedValues at:selectedLine ifAbsent:[^ self]
- ].
- objectToInspect inspect
+ inspectedValues isNil ifTrue:[
+ (selectedLine == 1) ifTrue:[
+ objectToInspect := inspectedObject
+ ] ifFalse:[
+ index := selectedLine - 1.
+ (inspectedObject class isVariable) ifFalse:[
+ objectToInspect := inspectedObject instVarAt:index
+ ] ifTrue:[
+ index <= (inspectedObject class instSize) ifTrue:[
+ objectToInspect := inspectedObject instVarAt:index
+ ] ifFalse:[
+ index := index - inspectedObject class instSize.
+ objectToInspect := inspectedObject basicAt:index
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ objectToInspect := inspectedValues at:selectedLine ifAbsent:[^ self]
+ ].
+ objectToInspect inspect
]
! !
--- a/Make.proto Mon Oct 10 04:15:21 1994 +0100
+++ b/Make.proto Mon Oct 10 04:16:24 1994 +0100
@@ -2,6 +2,15 @@
# -------------- no need to change anything below ----------
+#
+# there is one speciality to be found below:
+#
+# SBrowser became too big to be compiled on hp and NeXT
+# (and also takes up too much disk-space in the tmp-directory
+# for a typical sun installation).
+# Therefore, it is compiled in two pieces - this should
+# work on all systems.
+#
TOP=..
SUBDIRS=
@@ -9,10 +18,13 @@
STCOPT=$(LIBTOOL_STCOPT)
+SBROWSER_OBJ=SBrowser.$(O)
+# SBROWSER_OBJ=SBrowser_1.$(O) SBrowser_2.$(O)
+
all:: abbrev.stc objs classList.stc $(OBJTARGET)
objs:: \
- SBrowser.$(O) \
+ $(SBROWSER_OBJ) \
CBrowser.$(O) \
DebugView.$(O) \
Launcher.$(O) \
@@ -32,10 +44,23 @@
clean::
-rm -f *.c *.H classList.stc abbrev.stc
+ -rm SBrowser_1.st SBrowser_2.st
clobber::
-rm -f *.c *.H classList.stc abbrev.stc
+ -rm SBrowser_1.st SBrowser_2.st
+SPLIT: SBrowser_1.st SBrowser_2.st
+
+CLEAN:
+ @-rm SBrowser_1.st SBrowser_2.st
+
+SBrowser_1.st: SBrowser.st
+ sed '/class category menu/,$$d' < SBrowser.st > SBrowser_1.st
+
+SBrowser_2.st: SBrowser.st
+ echo "!SystemBrowser methodsFor:'class category menu'!" > SBrowser_2.st
+ sed '1,/class category menu/d' < SBrowser.st >> SBrowser_2.st
tar:
rm -f $(TOP)/DISTRIB/libtool.tar*
(cd $(TOP); tar cvf DISTRIB/libtool.tar \
@@ -56,20 +81,24 @@
#
# next thing I'll build into stc is a makedepend feature for this ...
#
-OBJECT=$(INCLUDE)/Object.H $(INCLUDE)/stc.h $(INCLUDE)/stcIntern.h
-VIEW=$(INCLUDE)/View.H $(OBJECT)
-STDSYSVIEW=$(INCLUDE)/StdSysV.H $(OBJECT)
+I=$(INCLUDE)
+OBJECT=$(I)/Object.H $(I)/stc.h $(I)/stcIntern.h
+VIEW=$(I)/View.H $(OBJECT)
+STDSYSVIEW=$(I)/StdSysV.H $(OBJECT)
InspView.$(O): InspView.st $(VIEW)
-DictInspV.$(O): DictInspV.st $(INCLUDE)/InspView.H $(VIEW)
-ConInspV.$(O): ConInspV.st $(INCLUDE)/InspView.H $(VIEW)
-OCInspView.$(O): OCInspView.st $(INCLUDE)/InspView.H $(VIEW)
+DictInspV.$(O): DictInspV.st $(I)/InspView.H $(VIEW)
+ConInspV.$(O): ConInspV.st $(I)/InspView.H $(VIEW)
+OCInspView.$(O): OCInspView.st $(I)/InspView.H $(VIEW)
+
+# FormEdtView.$(O): FormEdtView.st $(VIEW)
DebugView.$(O): DebugView.st $(STDSYSVIEW)
Launcher.$(O): Launcher.st $(STDSYSVIEW)
ProjectV.$(O): ProjectV.st $(STDSYSVIEW)
SBrowser.$(O): SBrowser.st $(STDSYSVIEW)
+SBrowser_1.$(O): SBrowser_1.st $(STDSYSVIEW)
+SBrowser_2.$(O): SBrowser_2.st $(STDSYSVIEW)
CBrowser.$(O): CBrowser.st $(STDSYSVIEW)
FBrowser.$(O): FBrowser.st $(STDSYSVIEW)
DirBrwsr.$(O): DirBrwsr.st $(STDSYSVIEW)
-FormEdtView.$(O): FormEdtView.st $(VIEW)
--- a/MemMonitor.st Mon Oct 10 04:15:21 1994 +0100
+++ b/MemMonitor.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,21 +1,31 @@
-'From Smalltalk/X, Version:1.5 on 4-Sep-91 at 18:41:13'!
+"
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
StandardSystemView subclass:#MemoryMonitor
- instanceVariableNames:'halted delay myBlock myProcess oldData newData sumData
- index org max min prevStringLen
- grey'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Debugger'
+ instanceVariableNames:'halted updateInterval updateBlock myProcess oldData newData
+ freeData sumData updateIndex org maxUsed minUsed newColor
+ freeColor oldColor prevFree prevOld'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
MemoryMonitor comment:'
-Shows memory usage (oldspace + newspace). Stupid, but works.
+Shows memory usage (oldspace + newspace). Simple, but useful.
'!
!MemoryMonitor class methodsFor:'startup'!
-start
+open
|m|
m := self origin:0 @ 0 extent:(200 @ 100).
@@ -27,60 +37,7 @@
m open.
^ m
- "MemoryMonitor start"
-! !
-
-!MemoryMonitor methodsFor:'initialization'!
-
-initialize
- super initialize.
-
- halted := false.
- delay := 0.5.
- ProcessorScheduler isPureEventDriven ifTrue:[
- myBlock := [self updateDisplay].
- ].
- oldData := Array new:1000.
- newData := Array new:1000.
- index := 1.
- org := font widthOf:'9999999'.
- max := ObjectMemory bytesUsed + 100000.
- min := ObjectMemory bytesUsed.
- prevStringLen := nil.
- viewBackground := Black
-
- "MemoryMonitor start"
-!
-
-realize
- super realize.
- self enableKeyEvents.
- myBlock notNil ifTrue:[
- Processor addTimedBlock:myBlock after:delay.
- ] ifFalse:[
- myProcess := [
- |d|
-
- [true] whileTrue:[
- (Delay forSeconds:delay) wait.
- self updateDisplay
- ]
- ] forkAt:4.
- myProcess name:'monitor update'
- ].
- grey := Color grey on:device.
-! !
-
-!MemoryMonitor methodsFor:'destroying'!
-
-destroy
- myBlock notNil ifTrue:[
- Processor removeTimedBlock:myBlock.
- ] ifFalse:[
- myProcess terminate.
- myProcess := nil
- ].
- super destroy
+ "MemoryMonitor open"
! !
!MemoryMonitor methodsFor:'drawing'!
@@ -88,128 +45,269 @@
updateDisplay
"update picture; trigger next update"
- |h hOld memUsed oldMemUsed newMemUsed x half scaleChange s thisStringLen|
+ |hAll hOld hFree memUsed oldMemUsed newMemUsed freeMem x y half scaleChange s thisStringLen scale|
realized ifFalse:[^ self].
- oldMemUsed := ObjectMemory oldSpaceUsed.
- newMemUsed := ObjectMemory newSpaceUsed.
- memUsed := oldMemUsed + newMemUsed.
- oldData at:index put:oldMemUsed.
- newData at:index put:newMemUsed.
+ shown ifTrue:[
+ oldMemUsed := ObjectMemory oldSpaceUsed.
+ newMemUsed := ObjectMemory newSpaceUsed.
+ freeMem := ObjectMemory freeListSpace.
+ memUsed := oldMemUsed + newMemUsed.
- h := (memUsed - min) * height // (max - min).
- hOld := (oldMemUsed - min) * height // (max - min).
+ scaleChange := false.
+ (memUsed < minUsed) ifTrue:[
+ minUsed := memUsed.
+ scaleChange := true
+ ].
+ (memUsed - freeMem < minUsed) ifTrue:[
+ minUsed := memUsed - freeMem.
+ scaleChange := true
+ ].
+ (memUsed > maxUsed) ifTrue:[
+ maxUsed := memUsed.
+ scaleChange := true
+ ].
+ scaleChange ifTrue:[
+ self clear.
+ self redraw
+ ].
- x := index - 1 + org.
+ oldData at:updateIndex put:oldMemUsed.
+ newData at:updateIndex put:newMemUsed.
+ freeData at:updateIndex put:freeMem.
+
+ scale := height asFloat / (maxUsed - minUsed + 200000).
+
+ hAll := ((memUsed - minUsed) * scale) asInteger.
+ hOld := ((oldMemUsed - minUsed + 100000) * scale) asInteger.
+ hFree := (freeMem * scale) asInteger.
+
+ x := updateIndex - 1 + org.
+ y := height - 1.
+
+ self paint:newColor.
+ self displayLineFromX:x y:y toX:x y:(y - hAll).
- self paint:grey.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - h).
+ self paint:oldColor.
+ self displayLineFromX:x y:y toX:x y:(y - hOld).
+
+ self paint:freeColor.
+ self displayLineFromX:x y:y-hOld toX:x y:(y - hOld + hFree).
+
+ self paint:White on:Black.
- self paint:White.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - hOld).
+ self paint:newColor.
+ s := 'all ' , ((memUsed // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height // 2 - font height).
+
+ freeMem ~~ prevFree ifTrue:[
+ self paint:freeColor.
+ s := 'free' , ((freeMem // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height // 2 + font descent).
+ prevFree := freeMem.
+ ].
- s := (memUsed // 1024) printString , 'k'.
- thisStringLen := s size.
- (thisStringLen ~~ prevStringLen) ifTrue:[
- prevStringLen notNil ifTrue:[
- self displayOpaqueString:' ' from:1 to:prevStringLen
- x:0 y:(height // 2 + font ascent)
- ]
+ (oldMemUsed - freeMem) ~~ prevOld ifTrue:[
+ self paint:oldColor.
+ s := 'old ' , (((oldMemUsed - freeMem) // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height // 2 + font height + (font descent * 2)).
+ prevOld := (oldMemUsed - freeMem).
+ ].
+
+ (updateIndex >= (width - org)) ifTrue:[
+ half := ((width - org) // 2) // 8 * 8.
+ oldData replaceFrom:1 to:half with:oldData startingAt:(half + 1).
+ newData replaceFrom:1 to:half with:newData startingAt:(half + 1).
+ freeData replaceFrom:1 to:half with:freeData startingAt:(half + 1).
+
+ self catchExpose.
+ self copyFrom:self x:(half + org) y:0
+ toX:org y:0
+ width:(width - org - half) height:height.
+ self clearRectangleX:(width - half) y:0 width:(width - org - half) height:height.
+ self waitForExpose.
+ updateIndex := updateIndex - half + 1
+ ] ifFalse:[
+ updateIndex := updateIndex + 1
+ ].
].
- self paint:White on:Black.
- self displayOpaqueString:s x:0 y:(height // 2 + font ascent).
- prevStringLen := thisStringLen.
-
- (index >= (width - org)) ifTrue:[
- half := ((width - org) // 2) // 8 * 8.
- oldData replaceFrom:1 to:half with:oldData startingAt:(half + 1).
- newData replaceFrom:1 to:half with:newData startingAt:(half + 1).
-
- self copyFrom:self x:(half + org) y:0
- toX:org y:0
- width:(width - org - half) height:height.
- self clearRectangleX:(width - half "- org" "org + half") y:0 width:(width - org - half) height:height.
- index := index - half
- ] ifFalse:[
- index := index + 1
+ updateBlock notNil ifTrue:[
+ Processor addTimedBlock:updateBlock afterSeconds:updateInterval
].
- scaleChange := false.
- (memUsed < min) ifTrue:[
- min := memUsed.
- scaleChange := true
- ].
- (memUsed > max) ifTrue:[
- max := memUsed.
- scaleChange := true
- ].
- scaleChange ifTrue:[
- self clear.
- self redraw
- ].
- myBlock notNil ifTrue:[
- Processor addTimedBlock:myBlock after:delay
- ].
+
!
redraw
"redraw data"
- |h hOld memUsed oldMemUsed x half|
+ |hAll hOld hFree memUsed oldMemUsed newMemUsed freeMem x y half scale s|
realized ifFalse:[^ self].
+ shown ifFalse:[^ self].
+
+ "
+ redraw all ...
+ "
+ self clipRect:nil.
x := org.
- 1 to:(index - 1) do:[:i |
- oldMemUsed := (oldData at:i).
- memUsed := oldMemUsed + (newData at:i).
- h := (((memUsed - min) asFloat / (max - min) asFloat) * height) asInteger.
- hOld := (((oldMemUsed - min) asFloat / (max - min) asFloat) * height) asInteger.
+ y := height - 1.
+ scale := height asFloat / (maxUsed - minUsed + 200000).
+
+ 1 to:(updateIndex - 1) do:[:i |
+ newMemUsed := (newData at:i).
+ oldMemUsed := (oldData at:i).
+ freeMem := freeData at:i.
+ memUsed := oldMemUsed + newMemUsed.
+
+ hAll := ((memUsed - minUsed) * scale) asInteger.
+ hOld := ((oldMemUsed - minUsed + 100000) * scale) asInteger.
+ hFree := (freeMem * scale) asInteger.
+
+ self paint:newColor.
+ self displayLineFromX:x y:y toX:x y:(y - hAll).
+
+ self paint:oldColor.
+ self displayLineFromX:x y:y toX:x y:(y - hOld).
+
+ self paint:freeColor.
+ self displayLineFromX:x y:y-hOld toX:x y:(y - hOld + hFree).
- self paint:grey.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - h).
+ x := x + 1
+ ].
+
+ self paint:White.
+ s := 'max ' , ((maxUsed // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayString:s x:0 y:font ascent.
+ s := 'min ' , ((minUsed // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayString:s x:0 y:(height - font descent).
+
+ prevFree := prevOld := nil.
- self paint:White.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - hOld).
- x := x + 1
+ "
+ since everything was draw, throw away other expose events
+ "
+ self sensor flushExposeEvents.
+
+
+! !
+
+!MemoryMonitor methodsFor:'destroying'!
+
+destroy
+ updateBlock notNil ifTrue:[
+ Processor removeTimedBlock:updateBlock.
+ ] ifFalse:[
+ myProcess terminate.
+ myProcess := nil
].
- self paint:White.
- self displayString:(((max // 1024) printString) , 'k') x:0 y:(font ascent).
- self displayString:(((min // 1024) printString) , 'k') x:0 y:(height - font descent)
+ super destroy
! !
!MemoryMonitor methodsFor:'events'!
keyPress:key x:x y:y
key == $f ifTrue:[
- delay := delay / 2
+ updateInterval := updateInterval / 2
].
key == $s ifTrue:[
- delay := delay * 2
+ updateInterval := updateInterval * 2
]
!
sizeChanged
- |nn no|
+ |nn no nf oldSize|
- ((width - org) == oldData size) ifTrue:[^ self].
+ oldSize := oldData size.
+ ((width - org) == oldSize) ifTrue:[^ self].
+
nn := Array new:width.
no := Array new:width.
- (nn size > newData size) ifTrue:[
- nn replaceFrom:1 to:(newData size) with:newData.
- no replaceFrom:1 to:(oldData size) with:oldData
+ nf := Array new:width.
+
+ (nn size > oldSize) ifTrue:[
+ nn replaceFrom:1 to:oldSize with:newData.
+ no replaceFrom:1 to:oldSize with:oldData.
+ nf replaceFrom:1 to:oldSize with:freeData
] ifFalse:[
- (index > nn size) ifTrue:[
- nn replaceFrom:1 to:(nn size) with:newData
- startingAt:(index - nn size + 1 ).
- no replaceFrom:1 to:(no size) with:oldData
- startingAt:(index - no size + 1 ).
- index := newData size - 1
- ] ifFalse:[
- nn replaceFrom:1 to:(nn size) with:newData.
- no replaceFrom:1 to:(no size) with:oldData
- ]
+ (updateIndex > nn size) ifTrue:[
+ nn replaceFrom:1 to:oldSize with:newData
+ startingAt:(updateIndex - oldSize + 1 ).
+ no replaceFrom:1 to:oldSize with:oldData
+ startingAt:(updateIndex - oldSize + 1 ).
+ nf replaceFrom:1 to:oldSize with:freeData
+ startingAt:(updateIndex - oldSize + 1 ).
+ updateIndex := oldSize - 1
+ ] ifFalse:[
+ nn replaceFrom:1 to:oldSize with:newData.
+ no replaceFrom:1 to:oldSize with:oldData.
+ nf replaceFrom:1 to:oldSize with:freeData
+ ]
].
newData := nn.
- oldData := no
+ oldData := no.
+ freeData := nf
! !
+
+!MemoryMonitor methodsFor:'initialization'!
+
+realize
+ super realize.
+ updateBlock notNil ifTrue:[
+ Processor addTimedBlock:updateBlock afterSeconds:updateInterval.
+ ] ifFalse:[
+ myProcess := [
+ |d|
+
+ [true] whileTrue:[
+ (Delay forSeconds:updateInterval) wait.
+ self updateDisplay
+ ]
+ ] forkAt:5.
+ myProcess name:'monitor update'
+ ].
+
+ newColor := newColor on:device.
+ freeColor := freeColor on:device.
+ oldColor := oldColor on:device.
+
+ font := font on:device.
+!
+
+initialize
+ super initialize.
+
+ halted := false.
+ updateInterval := 0.5.
+ ProcessorScheduler isPureEventDriven ifTrue:[
+ updateBlock := [self updateDisplay].
+ ].
+ oldData := Array new:1000.
+ newData := Array new:1000.
+ freeData := Array new:1000.
+
+ updateIndex := 1.
+ org := font widthOf:'used:9999k '.
+
+ maxUsed := ObjectMemory bytesUsed.
+ minUsed := ObjectMemory bytesUsed.
+ viewBackground := Black.
+
+ device hasColors ifTrue:[
+ newColor := Color yellow.
+ freeColor := Color green.
+ oldColor := Color white.
+ ] ifFalse:[
+ newColor := Color grey:67.
+ freeColor := Color grey:33.
+ oldColor := Color white.
+ ].
+
+ self font:(Font family:'courier' face:'medium' style:'roman' size:10).
+
+ "
+ MemoryMonitor open
+ "
+! !
+
--- a/MemUsageV.st Mon Oct 10 04:15:21 1994 +0100
+++ b/MemUsageV.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,64 +1,61 @@
+"
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+'From Smalltalk/X, Version:2.10.3 on 30-sep-1994 at 11:13:14'!
+
StandardSystemView subclass:#MemoryUsageView
- instanceVariableNames:'info list sortBlock'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Debugger'
+ instanceVariableNames:'info list sortBlock'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
-!MemoryUsageView methodsFor:'realization'!
-
-realize
- super realize.
- self updateInfo.
- self sortByClass.
-! !
-
-!MemoryUsageView methodsFor:'initialization'!
-
-initialize
- |l helpView headLine|
+MemoryUsageView comment:'
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
+'!
- super initialize.
- self label:'Memory usage'.
-
- headLine := 'class # of insts avg sz bytes %mem'.
+!MemoryUsageView class methodsFor:'documentation'!
- l := Label in:self.
- l origin:(0.0 @ 0.0) corner:(1.0 @ l height).
- l borderWidth:0.
- l label:headLine.
- l adjust:#left.
-
- self extent:((font widthOf:headLine) + (device horizontalPixelPerMillimeter * 15) rounded) @ self height.
+copyright
+"
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
- helpView := ScrollableView for:ListView in:self.
- helpView origin:(0.0 @ l height)
- extent:[width @ (height - l height - l margin)].
-
- l origin:(helpView scrollBar width @ 0.0).
-
- list := helpView scrolledView.
- list origin:(0.0 @ 0.0) extent:(1.0 @ 1.0).
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
- list middleButtonMenu:(PopUpMenu
- labels:#(
- 'by class'
- 'by inst count'
- 'by memory usage'
- '-'
- 'update'
- )
+version
+"
+$Header: /cvs/stx/stx/libtool/Attic/MemUsageV.st,v 1.2 1994-10-10 03:15:56 claus Exp $
+"
+!
- selectors:#(sortByClass
- sortByInstCount
- sortByMemoryUsage
- nil
- update
- )
- receiver:self
- for:list).
+documentation
+"
+ this view shows an overview over the memory usage of the system.
+ usage:
+ MemoryUsageView new open
- "MemoryUsageView start"
+ Since scanning all memory takes some time, this is not done
+ automatically, but upon request. See the middlebuttonmenu-'update'
+ function.
+"
! !
!MemoryUsageView methodsFor:'menu actions'!
@@ -81,72 +78,62 @@
self updateDisplay
!
+inspectInstances
+ |line className class|
+
+ line := list selectionValue.
+ (line notNil and:[line notEmpty]) ifTrue:[
+ className := line asCollectionOfWords first.
+ "
+ special kludge
+ "
+ (className startsWith:'<') ifFalse:[
+ (className startsWith:'all') ifFalse:[
+ class := Smalltalk at:className asSymbol.
+ class allInstances inspect
+ ]
+ ]
+ ]
+!
+
update
self updateInfo.
self updateDisplay
! !
+!MemoryUsageView methodsFor:'realization'!
+
+realize
+ super realize.
+ self updateInfo.
+ self sortByClass.
+! !
+
!MemoryUsageView methodsFor:'private'!
-updateInfo
- self cursor:Cursor wait.
- list cursor:Cursor wait.
-
- info := IdentityDictionary new:600.
-
- "find all objects, collect stuff in info"
-
- ObjectMemory allObjectsDo:[:o |
- |i class|
+updateDisplay
+ "update the displayed list"
- o isBehavior ifTrue:[
- o isMeta ifTrue:[
- class := Metaclass
- ] ifFalse:[
- class := Class
- ]
- ] ifFalse:[
- class := o class.
- ].
- (info includesKey:class) ifFalse:[
- info at:class put:(Array with:class
- with:1
- with:(ObjectMemory sizeOf:o))
- ] ifTrue:[
- i := info at:class.
- i at:2 put:((i at:2) + 1).
- i at:3 put:((i at:3) + (ObjectMemory sizeOf:o))
- ]
- ].
-
- self cursor:Cursor normal.
- list cursor:Cursor normal.
-!
-
-updateDisplay
|classNames counts sumSizes percents avgSizes rawData l line allMemory overAllCount overAllAvgSize|
- self cursor:Cursor wait.
- list cursor:Cursor wait.
-
rawData := info asSortedCollection:sortBlock.
"this avoids getting a sorted collection in the collect: below"
rawData := rawData asArray.
classNames := rawData collect:[:i |
- |cls|
+ |cls|
- cls := i at:1.
- cls == Class ifTrue:[
- '<all classes>'
- ] ifFalse:[
- cls == Metaclass ifTrue:[
- '<all metaclasses>'
- ] ifFalse:[
- cls name
- ]
- ]
+ cls := i at:1.
+ cls == Class ifTrue:[
+ '<all classes>'
+ ] ifFalse:[
+ cls == Metaclass ifTrue:[
+ '<all metaclasses>'
+ ] ifFalse:[
+ cls name
+ ]
+ ]
].
counts := rawData collect:[:i | (i at:2) ].
@@ -157,12 +144,12 @@
l := OrderedCollection new.
1 to:classNames size do:[:i |
- line := (classNames at:i) printStringPaddedTo:30 with:Character space.
- line := line , ((counts at:i) printStringLeftPaddedTo:10).
- line := line , ((avgSizes at:i) printStringLeftPaddedTo:10).
- line := line , ((sumSizes at:i) printStringLeftPaddedTo:10).
- line := line , ((percents at:i) printStringLeftPaddedTo:7).
- l add:line
+ line := (classNames at:i) printStringPaddedTo:30 with:Character space.
+ line := line , ((counts at:i) printStringLeftPaddedTo:10).
+ line := line , ((avgSizes at:i) printStringLeftPaddedTo:10).
+ line := line , ((sumSizes at:i) printStringLeftPaddedTo:10).
+ line := line , ((percents at:i) printStringLeftPaddedTo:7).
+ l add:line
].
"add summary line"
@@ -178,7 +165,103 @@
l add:line.
list list:l.
+!
- self cursor:Cursor normal.
- list cursor:Cursor normal.
+updateInfo
+ "scan all memory and collect the information"
+
+ |myProcess myPriority|
+
+ windowGroup withCursor:Cursor wait do:[
+
+ info := IdentityDictionary new:600.
+
+ "find all objects, collect stuff in info"
+
+ "
+ this is a time consuming operation; therefore lower my priority ...
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+
+ [
+ ObjectMemory allObjectsDo:[:o |
+ |i class|
+
+ o isBehavior ifTrue:[
+ o isMeta ifTrue:[
+ class := Metaclass
+ ] ifFalse:[
+ class := Class
+ ]
+ ] ifFalse:[
+ class := o class.
+ ].
+ (info includesKey:class) ifFalse:[
+ info at:class put:(Array with:class
+ with:1
+ with:(ObjectMemory sizeOf:o))
+ ] ifTrue:[
+ i := info at:class.
+ i at:2 put:((i at:2) + 1).
+ i at:3 put:((i at:3) + (ObjectMemory sizeOf:o))
+ ]
+ ].
+ ] valueNowOrOnUnwindDo:[
+ myProcess priority:myPriority.
+ ].
+ ]
! !
+
+!MemoryUsageView methodsFor:'initialization'!
+
+initialize
+ |l helpView headLine|
+
+ super initialize.
+ self label:'Memory usage'.
+
+ headLine := ' class # of insts avg sz bytes %mem '.
+
+ l := Label in:self.
+ l origin:(0.0 @ 0.0) corner:(1.0 @ l height).
+ l borderWidth:0.
+ l label:headLine.
+ l adjust:#left.
+
+ self extent:((font widthOf:headLine) + (device horizontalPixelPerMillimeter * 15) rounded) @ self height.
+
+ helpView := ScrollableView for:SelectionInListView in:self.
+ helpView origin:(0.0 @ l height) corner:1.0 @ 1.0.
+
+ l origin:(helpView scrollBar width @ 0.0).
+
+ list := helpView scrolledView.
+ list font:(self font).
+ list middleButtonMenu:(PopUpMenu
+ labels:(
+ resources array:#(
+ 'sort by class'
+ 'sort by inst count'
+ 'sort by memory usage'
+ '-'
+ 'inspect instances'
+ '-'
+ 'update'
+ ))
+
+ selectors:#(sortByClass
+ sortByInstCount
+ sortByMemoryUsage
+ nil
+ inspectInstances
+ nil
+ update
+ )
+ receiver:self
+ for:list).
+
+ "MemoryUsageView start"
+! !
+
--- a/MemoryMonitor.st Mon Oct 10 04:15:21 1994 +0100
+++ b/MemoryMonitor.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,21 +1,31 @@
-'From Smalltalk/X, Version:1.5 on 4-Sep-91 at 18:41:13'!
+"
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
StandardSystemView subclass:#MemoryMonitor
- instanceVariableNames:'halted delay myBlock myProcess oldData newData sumData
- index org max min prevStringLen
- grey'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Debugger'
+ instanceVariableNames:'halted updateInterval updateBlock myProcess oldData newData
+ freeData sumData updateIndex org maxUsed minUsed newColor
+ freeColor oldColor prevFree prevOld'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
MemoryMonitor comment:'
-Shows memory usage (oldspace + newspace). Stupid, but works.
+Shows memory usage (oldspace + newspace). Simple, but useful.
'!
!MemoryMonitor class methodsFor:'startup'!
-start
+open
|m|
m := self origin:0 @ 0 extent:(200 @ 100).
@@ -27,60 +37,7 @@
m open.
^ m
- "MemoryMonitor start"
-! !
-
-!MemoryMonitor methodsFor:'initialization'!
-
-initialize
- super initialize.
-
- halted := false.
- delay := 0.5.
- ProcessorScheduler isPureEventDriven ifTrue:[
- myBlock := [self updateDisplay].
- ].
- oldData := Array new:1000.
- newData := Array new:1000.
- index := 1.
- org := font widthOf:'9999999'.
- max := ObjectMemory bytesUsed + 100000.
- min := ObjectMemory bytesUsed.
- prevStringLen := nil.
- viewBackground := Black
-
- "MemoryMonitor start"
-!
-
-realize
- super realize.
- self enableKeyEvents.
- myBlock notNil ifTrue:[
- Processor addTimedBlock:myBlock after:delay.
- ] ifFalse:[
- myProcess := [
- |d|
-
- [true] whileTrue:[
- (Delay forSeconds:delay) wait.
- self updateDisplay
- ]
- ] forkAt:4.
- myProcess name:'monitor update'
- ].
- grey := Color grey on:device.
-! !
-
-!MemoryMonitor methodsFor:'destroying'!
-
-destroy
- myBlock notNil ifTrue:[
- Processor removeTimedBlock:myBlock.
- ] ifFalse:[
- myProcess terminate.
- myProcess := nil
- ].
- super destroy
+ "MemoryMonitor open"
! !
!MemoryMonitor methodsFor:'drawing'!
@@ -88,128 +45,269 @@
updateDisplay
"update picture; trigger next update"
- |h hOld memUsed oldMemUsed newMemUsed x half scaleChange s thisStringLen|
+ |hAll hOld hFree memUsed oldMemUsed newMemUsed freeMem x y half scaleChange s thisStringLen scale|
realized ifFalse:[^ self].
- oldMemUsed := ObjectMemory oldSpaceUsed.
- newMemUsed := ObjectMemory newSpaceUsed.
- memUsed := oldMemUsed + newMemUsed.
- oldData at:index put:oldMemUsed.
- newData at:index put:newMemUsed.
+ shown ifTrue:[
+ oldMemUsed := ObjectMemory oldSpaceUsed.
+ newMemUsed := ObjectMemory newSpaceUsed.
+ freeMem := ObjectMemory freeListSpace.
+ memUsed := oldMemUsed + newMemUsed.
- h := (memUsed - min) * height // (max - min).
- hOld := (oldMemUsed - min) * height // (max - min).
+ scaleChange := false.
+ (memUsed < minUsed) ifTrue:[
+ minUsed := memUsed.
+ scaleChange := true
+ ].
+ (memUsed - freeMem < minUsed) ifTrue:[
+ minUsed := memUsed - freeMem.
+ scaleChange := true
+ ].
+ (memUsed > maxUsed) ifTrue:[
+ maxUsed := memUsed.
+ scaleChange := true
+ ].
+ scaleChange ifTrue:[
+ self clear.
+ self redraw
+ ].
- x := index - 1 + org.
+ oldData at:updateIndex put:oldMemUsed.
+ newData at:updateIndex put:newMemUsed.
+ freeData at:updateIndex put:freeMem.
+
+ scale := height asFloat / (maxUsed - minUsed + 200000).
+
+ hAll := ((memUsed - minUsed) * scale) asInteger.
+ hOld := ((oldMemUsed - minUsed + 100000) * scale) asInteger.
+ hFree := (freeMem * scale) asInteger.
+
+ x := updateIndex - 1 + org.
+ y := height - 1.
+
+ self paint:newColor.
+ self displayLineFromX:x y:y toX:x y:(y - hAll).
- self paint:grey.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - h).
+ self paint:oldColor.
+ self displayLineFromX:x y:y toX:x y:(y - hOld).
+
+ self paint:freeColor.
+ self displayLineFromX:x y:y-hOld toX:x y:(y - hOld + hFree).
+
+ self paint:White on:Black.
- self paint:White.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - hOld).
+ self paint:newColor.
+ s := 'all ' , ((memUsed // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height // 2 - font height).
+
+ freeMem ~~ prevFree ifTrue:[
+ self paint:freeColor.
+ s := 'free' , ((freeMem // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height // 2 + font descent).
+ prevFree := freeMem.
+ ].
- s := (memUsed // 1024) printString , 'k'.
- thisStringLen := s size.
- (thisStringLen ~~ prevStringLen) ifTrue:[
- prevStringLen notNil ifTrue:[
- self displayOpaqueString:' ' from:1 to:prevStringLen
- x:0 y:(height // 2 + font ascent)
- ]
+ (oldMemUsed - freeMem) ~~ prevOld ifTrue:[
+ self paint:oldColor.
+ s := 'old ' , (((oldMemUsed - freeMem) // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height // 2 + font height + (font descent * 2)).
+ prevOld := (oldMemUsed - freeMem).
+ ].
+
+ (updateIndex >= (width - org)) ifTrue:[
+ half := ((width - org) // 2) // 8 * 8.
+ oldData replaceFrom:1 to:half with:oldData startingAt:(half + 1).
+ newData replaceFrom:1 to:half with:newData startingAt:(half + 1).
+ freeData replaceFrom:1 to:half with:freeData startingAt:(half + 1).
+
+ self catchExpose.
+ self copyFrom:self x:(half + org) y:0
+ toX:org y:0
+ width:(width - org - half) height:height.
+ self clearRectangleX:(width - half) y:0 width:(width - org - half) height:height.
+ self waitForExpose.
+ updateIndex := updateIndex - half + 1
+ ] ifFalse:[
+ updateIndex := updateIndex + 1
+ ].
].
- self paint:White on:Black.
- self displayOpaqueString:s x:0 y:(height // 2 + font ascent).
- prevStringLen := thisStringLen.
-
- (index >= (width - org)) ifTrue:[
- half := ((width - org) // 2) // 8 * 8.
- oldData replaceFrom:1 to:half with:oldData startingAt:(half + 1).
- newData replaceFrom:1 to:half with:newData startingAt:(half + 1).
-
- self copyFrom:self x:(half + org) y:0
- toX:org y:0
- width:(width - org - half) height:height.
- self clearRectangleX:(width - half "- org" "org + half") y:0 width:(width - org - half) height:height.
- index := index - half
- ] ifFalse:[
- index := index + 1
+ updateBlock notNil ifTrue:[
+ Processor addTimedBlock:updateBlock afterSeconds:updateInterval
].
- scaleChange := false.
- (memUsed < min) ifTrue:[
- min := memUsed.
- scaleChange := true
- ].
- (memUsed > max) ifTrue:[
- max := memUsed.
- scaleChange := true
- ].
- scaleChange ifTrue:[
- self clear.
- self redraw
- ].
- myBlock notNil ifTrue:[
- Processor addTimedBlock:myBlock after:delay
- ].
+
!
redraw
"redraw data"
- |h hOld memUsed oldMemUsed x half|
+ |hAll hOld hFree memUsed oldMemUsed newMemUsed freeMem x y half scale s|
realized ifFalse:[^ self].
+ shown ifFalse:[^ self].
+
+ "
+ redraw all ...
+ "
+ self clipRect:nil.
x := org.
- 1 to:(index - 1) do:[:i |
- oldMemUsed := (oldData at:i).
- memUsed := oldMemUsed + (newData at:i).
- h := (((memUsed - min) asFloat / (max - min) asFloat) * height) asInteger.
- hOld := (((oldMemUsed - min) asFloat / (max - min) asFloat) * height) asInteger.
+ y := height - 1.
+ scale := height asFloat / (maxUsed - minUsed + 200000).
+
+ 1 to:(updateIndex - 1) do:[:i |
+ newMemUsed := (newData at:i).
+ oldMemUsed := (oldData at:i).
+ freeMem := freeData at:i.
+ memUsed := oldMemUsed + newMemUsed.
+
+ hAll := ((memUsed - minUsed) * scale) asInteger.
+ hOld := ((oldMemUsed - minUsed + 100000) * scale) asInteger.
+ hFree := (freeMem * scale) asInteger.
+
+ self paint:newColor.
+ self displayLineFromX:x y:y toX:x y:(y - hAll).
+
+ self paint:oldColor.
+ self displayLineFromX:x y:y toX:x y:(y - hOld).
+
+ self paint:freeColor.
+ self displayLineFromX:x y:y-hOld toX:x y:(y - hOld + hFree).
- self paint:grey.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - h).
+ x := x + 1
+ ].
+
+ self paint:White.
+ s := 'max ' , ((maxUsed // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayString:s x:0 y:font ascent.
+ s := 'min ' , ((minUsed // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayString:s x:0 y:(height - font descent).
+
+ prevFree := prevOld := nil.
- self paint:White.
- self displayLineFromX:x y:(height - 1) toX:x y:(height - 1 - hOld).
- x := x + 1
+ "
+ since everything was draw, throw away other expose events
+ "
+ self sensor flushExposeEvents.
+
+
+! !
+
+!MemoryMonitor methodsFor:'destroying'!
+
+destroy
+ updateBlock notNil ifTrue:[
+ Processor removeTimedBlock:updateBlock.
+ ] ifFalse:[
+ myProcess terminate.
+ myProcess := nil
].
- self paint:White.
- self displayString:(((max // 1024) printString) , 'k') x:0 y:(font ascent).
- self displayString:(((min // 1024) printString) , 'k') x:0 y:(height - font descent)
+ super destroy
! !
!MemoryMonitor methodsFor:'events'!
keyPress:key x:x y:y
key == $f ifTrue:[
- delay := delay / 2
+ updateInterval := updateInterval / 2
].
key == $s ifTrue:[
- delay := delay * 2
+ updateInterval := updateInterval * 2
]
!
sizeChanged
- |nn no|
+ |nn no nf oldSize|
- ((width - org) == oldData size) ifTrue:[^ self].
+ oldSize := oldData size.
+ ((width - org) == oldSize) ifTrue:[^ self].
+
nn := Array new:width.
no := Array new:width.
- (nn size > newData size) ifTrue:[
- nn replaceFrom:1 to:(newData size) with:newData.
- no replaceFrom:1 to:(oldData size) with:oldData
+ nf := Array new:width.
+
+ (nn size > oldSize) ifTrue:[
+ nn replaceFrom:1 to:oldSize with:newData.
+ no replaceFrom:1 to:oldSize with:oldData.
+ nf replaceFrom:1 to:oldSize with:freeData
] ifFalse:[
- (index > nn size) ifTrue:[
- nn replaceFrom:1 to:(nn size) with:newData
- startingAt:(index - nn size + 1 ).
- no replaceFrom:1 to:(no size) with:oldData
- startingAt:(index - no size + 1 ).
- index := newData size - 1
- ] ifFalse:[
- nn replaceFrom:1 to:(nn size) with:newData.
- no replaceFrom:1 to:(no size) with:oldData
- ]
+ (updateIndex > nn size) ifTrue:[
+ nn replaceFrom:1 to:oldSize with:newData
+ startingAt:(updateIndex - oldSize + 1 ).
+ no replaceFrom:1 to:oldSize with:oldData
+ startingAt:(updateIndex - oldSize + 1 ).
+ nf replaceFrom:1 to:oldSize with:freeData
+ startingAt:(updateIndex - oldSize + 1 ).
+ updateIndex := oldSize - 1
+ ] ifFalse:[
+ nn replaceFrom:1 to:oldSize with:newData.
+ no replaceFrom:1 to:oldSize with:oldData.
+ nf replaceFrom:1 to:oldSize with:freeData
+ ]
].
newData := nn.
- oldData := no
+ oldData := no.
+ freeData := nf
! !
+
+!MemoryMonitor methodsFor:'initialization'!
+
+realize
+ super realize.
+ updateBlock notNil ifTrue:[
+ Processor addTimedBlock:updateBlock afterSeconds:updateInterval.
+ ] ifFalse:[
+ myProcess := [
+ |d|
+
+ [true] whileTrue:[
+ (Delay forSeconds:updateInterval) wait.
+ self updateDisplay
+ ]
+ ] forkAt:5.
+ myProcess name:'monitor update'
+ ].
+
+ newColor := newColor on:device.
+ freeColor := freeColor on:device.
+ oldColor := oldColor on:device.
+
+ font := font on:device.
+!
+
+initialize
+ super initialize.
+
+ halted := false.
+ updateInterval := 0.5.
+ ProcessorScheduler isPureEventDriven ifTrue:[
+ updateBlock := [self updateDisplay].
+ ].
+ oldData := Array new:1000.
+ newData := Array new:1000.
+ freeData := Array new:1000.
+
+ updateIndex := 1.
+ org := font widthOf:'used:9999k '.
+
+ maxUsed := ObjectMemory bytesUsed.
+ minUsed := ObjectMemory bytesUsed.
+ viewBackground := Black.
+
+ device hasColors ifTrue:[
+ newColor := Color yellow.
+ freeColor := Color green.
+ oldColor := Color white.
+ ] ifFalse:[
+ newColor := Color grey:67.
+ freeColor := Color grey:33.
+ oldColor := Color white.
+ ].
+
+ self font:(Font family:'courier' face:'medium' style:'roman' size:10).
+
+ "
+ MemoryMonitor open
+ "
+! !
+
--- a/MemoryUsageView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/MemoryUsageView.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,64 +1,61 @@
+"
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+'From Smalltalk/X, Version:2.10.3 on 30-sep-1994 at 11:13:14'!
+
StandardSystemView subclass:#MemoryUsageView
- instanceVariableNames:'info list sortBlock'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Debugger'
+ instanceVariableNames:'info list sortBlock'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
-!MemoryUsageView methodsFor:'realization'!
-
-realize
- super realize.
- self updateInfo.
- self sortByClass.
-! !
-
-!MemoryUsageView methodsFor:'initialization'!
-
-initialize
- |l helpView headLine|
+MemoryUsageView comment:'
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
+'!
- super initialize.
- self label:'Memory usage'.
-
- headLine := 'class # of insts avg sz bytes %mem'.
+!MemoryUsageView class methodsFor:'documentation'!
- l := Label in:self.
- l origin:(0.0 @ 0.0) corner:(1.0 @ l height).
- l borderWidth:0.
- l label:headLine.
- l adjust:#left.
-
- self extent:((font widthOf:headLine) + (device horizontalPixelPerMillimeter * 15) rounded) @ self height.
+copyright
+"
+ COPYRIGHT (c) 1992 by Claus Gittinger
+ All Rights Reserved
- helpView := ScrollableView for:ListView in:self.
- helpView origin:(0.0 @ l height)
- extent:[width @ (height - l height - l margin)].
-
- l origin:(helpView scrollBar width @ 0.0).
-
- list := helpView scrolledView.
- list origin:(0.0 @ 0.0) extent:(1.0 @ 1.0).
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
- list middleButtonMenu:(PopUpMenu
- labels:#(
- 'by class'
- 'by inst count'
- 'by memory usage'
- '-'
- 'update'
- )
+version
+"
+$Header: /cvs/stx/stx/libtool/MemoryUsageView.st,v 1.2 1994-10-10 03:15:56 claus Exp $
+"
+!
- selectors:#(sortByClass
- sortByInstCount
- sortByMemoryUsage
- nil
- update
- )
- receiver:self
- for:list).
+documentation
+"
+ this view shows an overview over the memory usage of the system.
+ usage:
+ MemoryUsageView new open
- "MemoryUsageView start"
+ Since scanning all memory takes some time, this is not done
+ automatically, but upon request. See the middlebuttonmenu-'update'
+ function.
+"
! !
!MemoryUsageView methodsFor:'menu actions'!
@@ -81,72 +78,62 @@
self updateDisplay
!
+inspectInstances
+ |line className class|
+
+ line := list selectionValue.
+ (line notNil and:[line notEmpty]) ifTrue:[
+ className := line asCollectionOfWords first.
+ "
+ special kludge
+ "
+ (className startsWith:'<') ifFalse:[
+ (className startsWith:'all') ifFalse:[
+ class := Smalltalk at:className asSymbol.
+ class allInstances inspect
+ ]
+ ]
+ ]
+!
+
update
self updateInfo.
self updateDisplay
! !
+!MemoryUsageView methodsFor:'realization'!
+
+realize
+ super realize.
+ self updateInfo.
+ self sortByClass.
+! !
+
!MemoryUsageView methodsFor:'private'!
-updateInfo
- self cursor:Cursor wait.
- list cursor:Cursor wait.
-
- info := IdentityDictionary new:600.
-
- "find all objects, collect stuff in info"
-
- ObjectMemory allObjectsDo:[:o |
- |i class|
+updateDisplay
+ "update the displayed list"
- o isBehavior ifTrue:[
- o isMeta ifTrue:[
- class := Metaclass
- ] ifFalse:[
- class := Class
- ]
- ] ifFalse:[
- class := o class.
- ].
- (info includesKey:class) ifFalse:[
- info at:class put:(Array with:class
- with:1
- with:(ObjectMemory sizeOf:o))
- ] ifTrue:[
- i := info at:class.
- i at:2 put:((i at:2) + 1).
- i at:3 put:((i at:3) + (ObjectMemory sizeOf:o))
- ]
- ].
-
- self cursor:Cursor normal.
- list cursor:Cursor normal.
-!
-
-updateDisplay
|classNames counts sumSizes percents avgSizes rawData l line allMemory overAllCount overAllAvgSize|
- self cursor:Cursor wait.
- list cursor:Cursor wait.
-
rawData := info asSortedCollection:sortBlock.
"this avoids getting a sorted collection in the collect: below"
rawData := rawData asArray.
classNames := rawData collect:[:i |
- |cls|
+ |cls|
- cls := i at:1.
- cls == Class ifTrue:[
- '<all classes>'
- ] ifFalse:[
- cls == Metaclass ifTrue:[
- '<all metaclasses>'
- ] ifFalse:[
- cls name
- ]
- ]
+ cls := i at:1.
+ cls == Class ifTrue:[
+ '<all classes>'
+ ] ifFalse:[
+ cls == Metaclass ifTrue:[
+ '<all metaclasses>'
+ ] ifFalse:[
+ cls name
+ ]
+ ]
].
counts := rawData collect:[:i | (i at:2) ].
@@ -157,12 +144,12 @@
l := OrderedCollection new.
1 to:classNames size do:[:i |
- line := (classNames at:i) printStringPaddedTo:30 with:Character space.
- line := line , ((counts at:i) printStringLeftPaddedTo:10).
- line := line , ((avgSizes at:i) printStringLeftPaddedTo:10).
- line := line , ((sumSizes at:i) printStringLeftPaddedTo:10).
- line := line , ((percents at:i) printStringLeftPaddedTo:7).
- l add:line
+ line := (classNames at:i) printStringPaddedTo:30 with:Character space.
+ line := line , ((counts at:i) printStringLeftPaddedTo:10).
+ line := line , ((avgSizes at:i) printStringLeftPaddedTo:10).
+ line := line , ((sumSizes at:i) printStringLeftPaddedTo:10).
+ line := line , ((percents at:i) printStringLeftPaddedTo:7).
+ l add:line
].
"add summary line"
@@ -178,7 +165,103 @@
l add:line.
list list:l.
+!
- self cursor:Cursor normal.
- list cursor:Cursor normal.
+updateInfo
+ "scan all memory and collect the information"
+
+ |myProcess myPriority|
+
+ windowGroup withCursor:Cursor wait do:[
+
+ info := IdentityDictionary new:600.
+
+ "find all objects, collect stuff in info"
+
+ "
+ this is a time consuming operation; therefore lower my priority ...
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+
+ [
+ ObjectMemory allObjectsDo:[:o |
+ |i class|
+
+ o isBehavior ifTrue:[
+ o isMeta ifTrue:[
+ class := Metaclass
+ ] ifFalse:[
+ class := Class
+ ]
+ ] ifFalse:[
+ class := o class.
+ ].
+ (info includesKey:class) ifFalse:[
+ info at:class put:(Array with:class
+ with:1
+ with:(ObjectMemory sizeOf:o))
+ ] ifTrue:[
+ i := info at:class.
+ i at:2 put:((i at:2) + 1).
+ i at:3 put:((i at:3) + (ObjectMemory sizeOf:o))
+ ]
+ ].
+ ] valueNowOrOnUnwindDo:[
+ myProcess priority:myPriority.
+ ].
+ ]
! !
+
+!MemoryUsageView methodsFor:'initialization'!
+
+initialize
+ |l helpView headLine|
+
+ super initialize.
+ self label:'Memory usage'.
+
+ headLine := ' class # of insts avg sz bytes %mem '.
+
+ l := Label in:self.
+ l origin:(0.0 @ 0.0) corner:(1.0 @ l height).
+ l borderWidth:0.
+ l label:headLine.
+ l adjust:#left.
+
+ self extent:((font widthOf:headLine) + (device horizontalPixelPerMillimeter * 15) rounded) @ self height.
+
+ helpView := ScrollableView for:SelectionInListView in:self.
+ helpView origin:(0.0 @ l height) corner:1.0 @ 1.0.
+
+ l origin:(helpView scrollBar width @ 0.0).
+
+ list := helpView scrolledView.
+ list font:(self font).
+ list middleButtonMenu:(PopUpMenu
+ labels:(
+ resources array:#(
+ 'sort by class'
+ 'sort by inst count'
+ 'sort by memory usage'
+ '-'
+ 'inspect instances'
+ '-'
+ 'update'
+ ))
+
+ selectors:#(sortByClass
+ sortByInstCount
+ sortByMemoryUsage
+ nil
+ inspectInstances
+ nil
+ update
+ )
+ receiver:self
+ for:list).
+
+ "MemoryUsageView start"
+! !
+
--- a/OldLauncher.st Mon Oct 10 04:15:21 1994 +0100
+++ b/OldLauncher.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -19,9 +19,9 @@
Launcher comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.15 1994-08-24 04:03:06 claus Exp $
+$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.16 1994-10-10 03:15:50 claus Exp $
'!
!Launcher class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.15 1994-08-24 04:03:06 claus Exp $
+$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.16 1994-10-10 03:15:50 claus Exp $
"
!
@@ -56,9 +56,9 @@
new
^ super
- extent:(100 @ 100)
- label:'smallTalk'
- icon:(Form fromFile:'SmalltalkX.xbm' resolution:100)
+ extent:(100 @ 100)
+ label:'smallTalk'
+ icon:(Form fromFile:'SmalltalkX.xbm' resolution:100)
"Launcher start"
! !
@@ -83,364 +83,366 @@
logoLabel form:(Image fromFile:'bitmaps/SmalltalkX.xbm').
logoLabel origin:0.0 @ 0.0.
logoLabel borderWidth:0.
+ logoLabel viewBackground:viewBackground.
+ logoLabel backgroundColor:viewBackground.
!
initializeMenu
myMenu := ClickMenuView
- labels:(resources array:#(
- 'Browsers'
- 'Workspace'
- 'File Browser'
- 'Projects'
- '-'
- 'Utilities'
- 'Goodies'
- 'Games & Demos'
- '-'
- 'info & help'
- '-'
- 'snapshot'
- '-'
- 'exit'
- ))
- selectors:#(browserMenu
- startWorkspace
- startFileBrowser
- projectMenu
- nil
- utilityMenu
- goodyMenu
- gamesMenu
- nil
- helpMenu
- nil
- saveImage
- nil
- exitSmalltalk
- )
- receiver:self
- in:self.
+ labels:(resources array:#(
+ 'Browsers'
+ 'Workspace'
+ 'File Browser'
+ 'Projects'
+ '-'
+ 'Utilities'
+ 'Goodies'
+ 'Games & Demos'
+ '-'
+ 'info & help'
+ '-'
+ 'snapshot'
+ '-'
+ 'exit'
+ ))
+ selectors:#(browserMenu
+ startWorkspace
+ startFileBrowser
+ projectMenu
+ nil
+ utilityMenu
+ goodyMenu
+ gamesMenu
+ nil
+ helpMenu
+ nil
+ saveImage
+ nil
+ exitSmalltalk
+ )
+ receiver:self
+ in:self.
myMenu subMenuAt:#browserMenu put:(
- PopUpMenu labels:(resources array:#(
- 'System Browser'
- 'Class Hierarchy Browser'
- 'Implementors'
- 'Senders'
- '-'
- 'Changes Browser'
- '-'
- 'Directory Browser'
- ))
- selectors:#(
- startSystemBrowser
- startHierarchyBrowser
- startImplementorsBrowser
- startSendersBrowser
- nil
- startChangesBrowser
- nil
- startDirectoryBrowser
- )
- receiver:self
- for:self
+ PopUpMenu labels:(resources array:#(
+ 'System Browser'
+ 'Class Hierarchy Browser'
+ 'Implementors'
+ 'Senders'
+ '-'
+ 'Changes Browser'
+ '-'
+ 'Directory Browser'
+ ))
+ selectors:#(
+ startSystemBrowser
+ startHierarchyBrowser
+ startImplementorsBrowser
+ startSendersBrowser
+ nil
+ startChangesBrowser
+ nil
+ startDirectoryBrowser
+ )
+ receiver:self
+ for:self
).
myMenu subMenuAt:#utilityMenu put:(
- PopUpMenu labels:(resources array:#(
- 'Transcript'
- '-'
- 'Window tree'
- 'View inspect'
- 'View destroy'
- 'Class tree'
- '-'
- 'Event monitor'
- 'Process monitor'
- 'Memory monitor'
- 'Memory usage'
- '-'
- 'collect Garbage'
- 'collect Garbage & compress'
- '-'
- 'full screen hardcopy'
- 'screen area hardcopy'
- 'view hardcopy'
- '-'
- 'ScreenSaver'
- ))
- selectors:#(
- startTranscript
- nil
- startWindowTreeView
- viewInspector
- viewKiller
- startClassTreeView
- nil
- startEventMonitor
- startProcessMonitor
- startMemoryMonitor
- startMemoryUsage
- nil
- garbageCollect
- compressingGarbageCollect
- nil
- fullScreenHardcopy
- screenHardcopy
- viewHardcopy
- nil
- screenSaverMenu
- )
- receiver:self
- for:self
+ PopUpMenu labels:(resources array:#(
+ 'Transcript'
+ '-'
+ 'Window tree'
+ 'View inspect'
+ 'View destroy'
+ 'Class tree'
+ '-'
+ 'Event monitor'
+ 'Process monitor'
+ 'Memory monitor'
+ 'Memory usage'
+ '-'
+ 'collect Garbage'
+ 'collect Garbage & compress'
+ '-'
+ 'full screen hardcopy'
+ 'screen area hardcopy'
+ 'view hardcopy'
+ '-'
+ 'ScreenSaver'
+ ))
+ selectors:#(
+ startTranscript
+ nil
+ startWindowTreeView
+ viewInspector
+ viewKiller
+ startClassTreeView
+ nil
+ startEventMonitor
+ startProcessMonitor
+ startMemoryMonitor
+ startMemoryUsage
+ nil
+ garbageCollect
+ compressingGarbageCollect
+ nil
+ fullScreenHardcopy
+ screenHardcopy
+ viewHardcopy
+ nil
+ screenSaverMenu
+ )
+ receiver:self
+ for:self
).
(myMenu subMenuAt:#utilityMenu) subMenuAt:#screenSaverMenu put:(
- PopUpMenu labels:(resources array:#(
- 'simple'
- 'spotlight'
- 'moving spotlight'
- ))
- selectors:#(
- startScreenSaver1
- startScreenSaver2
- startScreenSaver3
- )
- receiver:self
- for:self
+ PopUpMenu labels:(resources array:#(
+ 'simple'
+ 'spotlight'
+ 'moving spotlight'
+ ))
+ selectors:#(
+ startScreenSaver1
+ startScreenSaver2
+ startScreenSaver3
+ )
+ receiver:self
+ for:self
).
(Display isKindOf:GLXWorkstation) ifTrue:[
- myMenu subMenuAt:#gamesMenu put:(
- PopUpMenu labels:(resources array:#(
- 'Tetris'
- 'TicTacToe'
- '-'
- 'Animation'
- 'Globe'
- '-'
- 'GL 3D demos'
- '-'
- 'LogicTool'
- ))
- selectors:#(
- startTetris
- startTicTacToe
- nil
- startAnimation
- startGlobeDemo
- nil
- glDemos
- nil
- startLogicTool
- )
- receiver:self
- for:self
- ).
- (myMenu subMenuAt:#gamesMenu) subMenuAt:#glDemos put:(
- PopUpMenu labels:(resources array:#(
- 'plane'
- 'tetra'
- 'cube (wireframe)'
- 'cube (solid)'
- 'cube (light)'
- 'sphere (wireframe)'
- 'sphere (light)'
- 'planet'
- 'teapot'
- 'logo'
- ))
- selectors:#(
- startGLPlaneDemo
- startGLTetraDemo
- startGLWireCubeDemo
- startGLCubeDemo
- startGLCubeDemo2
- startGLWireSphereDemo
- startGLSphereDemo
- startGLPlanetDemo
- startGLTeapotDemo
- startGLLogoDemo1
- )
- receiver:self
- for:self
- ).
+ myMenu subMenuAt:#gamesMenu put:(
+ PopUpMenu labels:(resources array:#(
+ 'Tetris'
+ 'TicTacToe'
+ '-'
+ 'Animation'
+ 'Globe'
+ '-'
+ 'GL 3D demos'
+ '-'
+ 'LogicTool'
+ ))
+ selectors:#(
+ startTetris
+ startTicTacToe
+ nil
+ startAnimation
+ startGlobeDemo
+ nil
+ glDemos
+ nil
+ startLogicTool
+ )
+ receiver:self
+ for:self
+ ).
+ (myMenu subMenuAt:#gamesMenu) subMenuAt:#glDemos put:(
+ PopUpMenu labels:(resources array:#(
+ 'plane'
+ 'tetra'
+ 'cube (wireframe)'
+ 'cube (solid)'
+ 'cube (light)'
+ 'sphere (wireframe)'
+ 'sphere (light)'
+ 'planet'
+ 'teapot'
+ 'logo'
+ ))
+ selectors:#(
+ startGLPlaneDemo
+ startGLTetraDemo
+ startGLWireCubeDemo
+ startGLCubeDemo
+ startGLCubeDemo2
+ startGLWireSphereDemo
+ startGLSphereDemo
+ startGLPlanetDemo
+ startGLTeapotDemo
+ startGLLogoDemo1
+ )
+ receiver:self
+ for:self
+ ).
] ifFalse:[
- myMenu subMenuAt:#gamesMenu put:(
- PopUpMenu labels:(resources array:#(
- 'Tetris'
- 'TicTacToe'
- '-'
- 'Animation'
- 'Globe'
- '-'
- 'LogicTool'
- ))
- selectors:#(
- startTetris
- startTicTacToe
- nil
- startAnimation
- startGlobeDemo
- nil
- startLogicTool
- )
- receiver:self
- for:self
- )
+ myMenu subMenuAt:#gamesMenu put:(
+ PopUpMenu labels:(resources array:#(
+ 'Tetris'
+ 'TicTacToe'
+ '-'
+ 'Animation'
+ 'Globe'
+ '-'
+ 'LogicTool'
+ ))
+ selectors:#(
+ startTetris
+ startTicTacToe
+ nil
+ startAnimation
+ startGlobeDemo
+ nil
+ startLogicTool
+ )
+ receiver:self
+ for:self
+ )
].
Project notNil ifTrue:[
- myMenu subMenuAt:#projectMenu put:(
- PopUpMenu labels:(resources array:#(
- 'new project'
- '-'
- 'select project'
- ))
- selectors:#(
- newProject
- nil
- selectProject
- )
- receiver:self
- for:self
- ).
+ myMenu subMenuAt:#projectMenu put:(
+ PopUpMenu labels:(resources array:#(
+ 'new project'
+ '-'
+ 'select project'
+ ))
+ selectors:#(
+ newProject
+ nil
+ selectProject
+ )
+ receiver:self
+ for:self
+ ).
].
myMenu subMenuAt:#goodyMenu put:(
- PopUpMenu labels:(resources array:#(
- 'Clock'
- 'Round Clock'
+ PopUpMenu labels:(resources array:#(
+ 'Clock'
+ 'Round Clock'
"
- 'Address Book'
+ 'Address Book'
"
- '-'
- 'Directory View'
- 'MailTool'
- 'NewsTool'
- '-'
- 'DrawTool'
- ))
- selectors:#(
- startClock
- startRoundClock
+ '-'
+ 'Directory View'
+ 'MailTool'
+ 'NewsTool'
+ '-'
+ 'DrawTool'
+ ))
+ selectors:#(
+ startClock
+ startRoundClock
"
- startAddressBook
+ startAddressBook
"
- nil
- startDirectoryView
- startMailTool
- startNewsTool
- nil
- startDrawTool
- )
- receiver:self
- for:self
+ nil
+ startDirectoryView
+ startMailTool
+ startNewsTool
+ nil
+ startDrawTool
+ )
+ receiver:self
+ for:self
).
myMenu subMenuAt:#helpMenu put:(
- PopUpMenu labels:(resources array:#(
- 'About'
- '-'
- 'Overview'
- 'Getting started'
- 'Customizing'
- 'Tools'
- 'programming'
- 'other topics'
- '-'
+ PopUpMenu labels:(resources array:#(
+ 'About'
+ '-'
+ 'Overview'
+ 'Getting started'
+ 'Customizing'
+ 'Tools'
+ 'programming'
+ 'other topics'
+ '-'
"
- 'Help Browser'
+ 'Help Browser'
"
- 'Manual Browser'
- ))
- selectors:#(
- showAbout
- nil
- showOverview
- showGettingStarted
- showCustomizing
- tools
- programming
- otherTopics
- nil
+ 'Manual Browser'
+ ))
+ selectors:#(
+ showAbout
+ nil
+ showOverview
+ showGettingStarted
+ showCustomizing
+ tools
+ programming
+ otherTopics
+ nil
"
- startHelpView
+ startHelpView
"
- startManualBrowser
- )
- receiver:self
- for:self
+ startManualBrowser
+ )
+ receiver:self
+ for:self
).
(myMenu subMenuAt:#helpMenu) subMenuAt:#tools put:(
- PopUpMenu labels:(resources array:#(
- 'System Browser'
- 'File Browser'
- 'Changes Browser'
- 'Debugger'
- 'Inspector'
- ))
- selectors:#(
- showSystemBrowserDocumentation
- showFileBrowserDocumentation
- showChangesBrowserDocumentation
- showDebuggerDocumentation
- showInspectorDocumentation
- )
- receiver:self
- for:self
+ PopUpMenu labels:(resources array:#(
+ 'System Browser'
+ 'File Browser'
+ 'Changes Browser'
+ 'Debugger'
+ 'Inspector'
+ ))
+ selectors:#(
+ showSystemBrowserDocumentation
+ showFileBrowserDocumentation
+ showChangesBrowserDocumentation
+ showDebuggerDocumentation
+ showInspectorDocumentation
+ )
+ receiver:self
+ for:self
).
(myMenu subMenuAt:#helpMenu) subMenuAt:#otherTopics put:(
- PopUpMenu labels:(resources array:#(
- 'ST/X history'
- 'Garbage collection'
- 'Language & primitives'
- 'Error messages'
- '-'
- 'stc manual page'
- 'smalltalk manual page'
- ))
- selectors:#(
- showHistoryDocumentation
- showGCDocumentation
- showLanguageDocumentation
- showErrorMessageDocumentation
- nil
- showSTCManualPage
- showSmalltalkManualPage
- )
- receiver:self
- for:self
+ PopUpMenu labels:(resources array:#(
+ 'ST/X history'
+ 'Garbage collection'
+ 'Language & primitives'
+ 'Error messages'
+ '-'
+ 'stc manual page'
+ 'smalltalk manual page'
+ ))
+ selectors:#(
+ showHistoryDocumentation
+ showGCDocumentation
+ showLanguageDocumentation
+ showErrorMessageDocumentation
+ nil
+ showSTCManualPage
+ showSmalltalkManualPage
+ )
+ receiver:self
+ for:self
).
(myMenu subMenuAt:#helpMenu) subMenuAt:#programming put:(
- PopUpMenu labels:(resources array:#(
- 'useful selectors'
- 'views - quick intro'
- 'breakpoints & tracing'
- 'processes'
- 'timers & delays'
- 'exceptions & signals'
- 'GL 3D graphics'
- ))
- selectors:#(
- showUsefulSelectors
- showQuickViewIntro
- showDebuggingInfo
- showProcessInfo
- showTimerInfo
- showExceptionInfo
- showGLDocumentation
- )
- receiver:self
- for:self
+ PopUpMenu labels:(resources array:#(
+ 'useful selectors'
+ 'views - quick intro'
+ 'breakpoints & tracing'
+ 'processes'
+ 'timers & delays'
+ 'exceptions & signals'
+ 'GL 3D graphics'
+ ))
+ selectors:#(
+ showUsefulSelectors
+ showQuickViewIntro
+ showDebuggingInfo
+ showProcessInfo
+ showTimerInfo
+ showExceptionInfo
+ showGLDocumentation
+ )
+ receiver:self
+ for:self
).
!
@@ -458,18 +460,18 @@
catch errors - dont want a debugger here ...
"
Processor activeProcess emergencySignalHandler:[:ex |
- |box|
+ |box|
- box := YesNoBox title:('Error while launching ...\' , ex errorString , '\\debug ?') withCRs.
- "
- icon should be whatever WarnBoxes use as icon
- "
- box formLabel form:(WarningBox new formLabel label).
- box yesAction:[Debugger
- enter:ex suspendedContext
- withMessage:ex errorString].
- box showAtPointer.
- Object abortSignal raise.
+ box := YesNoBox title:('Error while launching ...\' , ex errorString , '\\debug ?') withCRs.
+ "
+ icon should be whatever WarnBoxes use as icon
+ "
+ box formLabel form:(WarningBox new formLabel label).
+ box yesAction:[Debugger
+ enter:ex suspendedContext
+ withMessage:ex errorString].
+ box showAtPointer.
+ Object abortSignal raise.
].
!
@@ -483,12 +485,12 @@
!
destroy
- "re-confirm when clisng Launcher - since if you closed
- the last launcher, you might loose the possibility to
+ "re-confirm when closing Launcher - we do this,
+ since if you close the last launcher, you might loose the possibility to
communicate with the system ..."
(self confirm:(resources string:'close Launcher ?')) ifTrue:[
- super destroy
+ super destroy
]
!
@@ -512,18 +514,18 @@
isRTF := true.
s := Smalltalk systemFileStreamFor:name , '.rtf'.
s isNil ifTrue:[
- isRTF := false.
- s := Smalltalk systemFileStreamFor:name , '.doc'.
- s isNil ifTrue:[
- self warn:('document ' , name , ' (.rtf/.doc) not available.\\check your installation.' withCRs).
- ^ nil
- ].
+ isRTF := false.
+ s := Smalltalk systemFileStreamFor:name , '.doc'.
+ s isNil ifTrue:[
+ self warn:('document ' , name , ' (.rtf/.doc) not available.\\check your installation.' withCRs).
+ ^ nil
+ ].
].
f := s pathName.
isRTF ifTrue:[
- DocumentView openOn:f.
- ^ self
+ DocumentView openOn:f.
+ ^ self
].
(Workspace openOn:f) readOnly
@@ -536,10 +538,10 @@
|box|
box := FileSelectionBox
- title:'save image in:'
- okText:'save'
- abortText:'cancel'
- action:[:fileName | anImage saveOn:fileName].
+ title:'save image in:'
+ okText:'save'
+ abortText:'cancel'
+ action:[:fileName | anImage saveOn:fileName].
box pattern:'*.tiff'.
box showAtPointer
!
@@ -572,14 +574,14 @@
enterBox okText:(resources at:'browse').
enterBox action:[:className |
- |class|
+ |class|
- class := Smalltalk at:className asSymbol ifAbsent:[nil].
- class isBehavior ifFalse:[
- self warn:(resources at:'no such class')
- ] ifTrue:[
- SystemBrowser browseClassHierarchy:class
- ]
+ class := Smalltalk at:className asSymbol ifAbsent:[nil].
+ class isBehavior ifFalse:[
+ self warn:'no such class'
+ ] ifTrue:[
+ SystemBrowser browseClassHierarchy:class
+ ]
].
enterBox showAtPointer
!
@@ -593,7 +595,7 @@
enterBox okText:(resources at:'browse').
enterBox action:[:selectorName |
- SystemBrowser browseImplementorsOf:selectorName
+ SystemBrowser browseImplementorsOf:selectorName
].
enterBox showAtPointer
!
@@ -607,7 +609,7 @@
enterBox okText:(resources at:'browse').
enterBox action:[:selectorName |
- SystemBrowser browseAllCallsOn:selectorName
+ SystemBrowser browseAllCallsOn:selectorName
].
enterBox showAtPointer
!
@@ -637,15 +639,15 @@
saveBox := EnterBox new.
saveBox title:(resources at:'filename for image:') withCRs.
- " saveBox abortText:(resources at:'abort')." "this is the default anyway ..."
saveBox okText:(resources at:'save').
-
- "this is a kludge - put into above if-block once
- stack contexts survive a snapout/snapin
- (I think, it could be done now ...)
- "
saveBox action:[:fileName |
- ObjectMemory snapShotOn:fileName.
+ (ObjectMemory snapShotOn:fileName) ifFalse:[
+ "
+ snapshot failed for some reason (disk full, no permission etc.)
+ Do NOT exit in this case.
+ "
+ self warn:(resources string:'failed to save snapshot image').
+ ]
].
saveBox initialText:(ObjectMemory nameForSnapshot).
@@ -657,27 +659,36 @@
exitBox := EnterBox2 new.
exitBox title:(resources at:'save state before exiting ?\\filename for image:') withCRs.
- " exitBox abortText:(resources at:'abort')." "this is the default anyway ..."
exitBox okText:(resources at:'exit').
exitBox okText2:(resources at:'save & exit').
exitBox action:[:dummyName |
- self closeDownViews.
- Smalltalk exit
+ self closeDownViews.
+ Smalltalk exit
].
exitBox action2:[:fileName |
- ObjectMemory snapShotOn:fileName.
+ (ObjectMemory snapShotOn:fileName) ifFalse:[
+ "
+ snapshot failed for some reason (disk full, no permission etc.)
+ Do NOT exit in this case.
+ "
+ self warn:(resources string:'failed to save snapshot image').
+ ] ifTrue:[
+ "
+ closeDownViews tells all views to shutdown neatly
+ (i.e. offer a chance to save the contents to a file).
- "this is NOT required - all data should be in the snapshot ...
- ... however, if remote disks/mounatble filesystems are involved,
- which may not be present the next time, it may make sense to
- uncomment it and query for saving - time will show which is better.
- "
+ This is NOT required - all data should be in the snapshot ...
+ ... however, if remote disks/mountable filesystems are involved,
+ which may not be present the next time, it may make sense to
+ uncomment it and query for saving - time will show which is better.
+ "
"
- self closeDownViews.
+ self closeDownViews.
"
- Smalltalk exit
+ Smalltalk exit
+ ]
].
exitBox initialText:(ObjectMemory nameForSnapshot).
@@ -687,30 +698,40 @@
!Launcher methodsFor:'utility menu actions'!
viewHardcopy
- Processor addTimedBlock:[
- |v|
+ "after a second (to allow redraw of views under menu ...),
+ let user specify a view and save its contents."
- v := Display viewFromUser.
- v notNil ifTrue:[
- self saveScreenImage:(Image fromView:(v topView))
- ]
+ Processor addTimedBlock:[
+ |v|
+
+ v := Display viewFromUser.
+ v notNil ifTrue:[
+ self saveScreenImage:(Image fromView:(v topView))
+ ]
] afterSeconds:1
!
fullScreenHardcopy
+ "after a second (to allow redraw of views under menu ...),
+ save the contents of the whole screen."
+
Processor addTimedBlock:[
- self saveScreenImage:(Image fromScreen)
+ self saveScreenImage:(Image fromScreen)
] afterSeconds:1
!
screenHardcopy
+ "after a second (to allow redraw of views under menu ...),
+ let user specify a rectangular area on the screen
+ and save its contents."
+
|area|
Processor addTimedBlock:[
- area := Rectangle fromUser.
- (area width > 0 and:[area height > 0]) ifTrue:[
- self saveScreenImage:(Image fromScreen:area)
- ]
+ area := Rectangle fromUser.
+ (area width > 0 and:[area height > 0]) ifTrue:[
+ self saveScreenImage:(Image fromScreen:area)
+ ]
] afterSeconds:1
!
@@ -720,9 +741,9 @@
(Delay forSeconds:1) wait.
v := Display viewFromUser.
v isNil ifTrue:[
- self warn:'sorry, this is not a smalltalk view'
+ self warn:'sorry, this is not a smalltalk view'
] ifFalse:[
- v topView destroy
+ v topView destroy
]
!
@@ -732,9 +753,9 @@
(Delay forSeconds:1) wait.
v := Display viewFromUser.
v isNil ifTrue:[
- self warn:'sorry, this is not a smalltalk view'
+ self warn:'sorry, this is not a smalltalk view'
] ifFalse:[
- v topView inspect
+ v topView inspect
]
!
@@ -763,16 +784,16 @@
!
startTranscript
- ((Smalltalk at:#Transcript) isKindOf:TextCollector) ifTrue:[
- "there is only one transcript"
- Transcript topView isCollapsed ifTrue:[
- "it is iconified"
- Transcript topView unrealize.
- Transcript topView realize.
- ].
- Transcript topView raise
+ (Transcript isKindOf:TextCollector) ifTrue:[
+ "there is only one transcript"
+ Transcript topView isCollapsed ifTrue:[
+ "it is iconified"
+ Transcript topView unrealize.
+ Transcript topView realize.
+ ].
+ Transcript topView raise
] ifFalse:[
- Smalltalk at:#Transcript put:(TextCollector newTranscript)
+ Transcript := TextCollector newTranscript
]
!
@@ -799,19 +820,19 @@
ObjectMemory garbageCollect.
nReclaimed := nBytesBefore - ObjectMemory oldSpaceUsed.
nReclaimed > 0 ifTrue:[
- Transcript show:'reclaimed '.
- nReclaimed > 1024 ifTrue:[
- nReclaimed > (1024 * 1024) ifTrue:[
- Transcript show:(nReclaimed // (1024 * 1024)) printString.
- Transcript showCr:' Mb.'
- ] ifFalse:[
- Transcript show:(nReclaimed // 1024) printString.
- Transcript showCr:' Kb.'
- ]
- ] ifFalse:[
- Transcript show:nReclaimed printString.
- Transcript showCr:' bytes.'
- ]
+ Transcript show:'reclaimed '.
+ nReclaimed > 1024 ifTrue:[
+ nReclaimed > (1024 * 1024) ifTrue:[
+ Transcript show:(nReclaimed // (1024 * 1024)) printString.
+ Transcript showCr:' Mb.'
+ ] ifFalse:[
+ Transcript show:(nReclaimed // 1024) printString.
+ Transcript showCr:' Kb.'
+ ]
+ ] ifFalse:[
+ Transcript show:nReclaimed printString.
+ Transcript showCr:' bytes.'
+ ]
]
! !
@@ -835,15 +856,15 @@
box list:(list collect:[:p | p name]).
box title:(resources string:'select a project').
box action:[:selection |
- |project|
+ |project|
- project := list detect:[:p | p name = selection] ifNone:[nil].
- project isNil ifTrue:[
- Transcript showCr:'no such project'
- ] ifFalse:[
- project showViews.
- Project current:project
- ]
+ project := list detect:[:p | p name = selection] ifNone:[nil].
+ project isNil ifTrue:[
+ Transcript showCr:'no such project'
+ ] ifFalse:[
+ project showViews.
+ Project current:project
+ ]
].
box showAtPointer
! !
@@ -951,8 +972,8 @@
s := Smalltalk systemFileStreamFor:aPath.
s isNil ifTrue:[
- self warn:('document ' , aPath , ' not available').
- ^ nil
+ self warn:('document ' , aPath , ' not available').
+ ^ nil
].
^ s pathName
!
@@ -961,21 +982,21 @@
|box dark green|
device hasColors ifTrue:[
- green := (Color red:0 green:80 blue:20) darkened.
+ green := (Color red:0 green:80 blue:20) darkened.
] ifFalse:[
- green := White.
+ green := White.
].
device hasGreyscales ifTrue:[
- dark := Color grey:10.
+ dark := Color grey:10.
] ifFalse:[
- dark := Black.
+ dark := Black.
].
box := InfoBox new.
- box viewBackground:dark.
+ box viewBackground:dark; allSubViewsDo:[:s | s viewBackground:dark].
box form:(Form
- fromFile:'SmalltalkX.xbm'
- resolution:100).
+ fromFile:'SmalltalkX.xbm'
+ resolution:100).
box formLabel viewBackground:dark.
box formLabel foregroundColor:green backgroundColor:dark.
box textLabel viewBackground:dark.
@@ -1087,14 +1108,14 @@
startManualBrowser
ManualBrowser isLoaded ifFalse:[
- ManualBrowser autoload.
- "
- did it load ?
- "
- ManualBrowser isLoaded ifFalse:[
- self warn:'The ManualBrowser is a Tomcat add-on; not included in this package.'.
- ^self
- ]
+ ManualBrowser autoload.
+ "
+ did it load ?
+ "
+ ManualBrowser isLoaded ifFalse:[
+ self warn:'The ManualBrowser is a Tomcat add-on; not included in this package.'.
+ ^self
+ ]
].
self warn:'The HelpSystem is still under construction.
--- a/ProcMonitor.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ProcMonitor.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,17 +1,15 @@
StandardSystemView subclass:#ProcessMonitor
- instanceVariableNames:'listView processes listUpdateDelay updateDelay runnableColor suspendedColor
- updateBlock listUpdateBlock updateProcess'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Debugger'
+ instanceVariableNames:'listView processes listUpdateDelay updateDelay
+ updateBlock listUpdateBlock updateProcess hideDead
+ runColor suspendedColor waitColor'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
-ProcessMonitor comment:'
-'!
-
!ProcessMonitor class methodsFor:'startup'!
-start
+open
|m|
m := self new.
@@ -22,127 +20,176 @@
m open.
^ m
- "ProcessMonitor start"
+ "
+ ProcessMonitor open
+ "
! !
!ProcessMonitor methodsFor:'initialization'!
initialize
- |v|
+ |v menu|
super initialize.
- self extent:(font widthOf:'name/id state prio usedStack maxStack')
- + 40 @
- 100.
+ hideDead := true.
+
+ self extent:(font widthOf:'name/id state prio usedStack maxStack')
+ + 40 @
+ 100.
v := ScrollableView for:SelectionInListView in:self.
v origin:0.0@0.0 corner:1.0@1.0.
listView := v scrolledView.
listView font:font.
- listView middleButtonMenu:(PopUpMenu
- labels:#(
- 'inspect'
- 'debug'
- '-'
- 'resume'
- 'suspend'
- 'terminate'
- )
- selectors:#(inspectProcess
- debugProcess
- nil
- resumeProcess
- suspendProcess
- terminateProcess
- )
- receiver:self
- for:listView).
+ menu := (PopUpMenu
+ labels:#(
+"/ hideDead functionality no longer needed;
+"/ since ProcSched knownProcesses only returns living ones
+"/
+"/ '\c hide dead'
+"/ '-'
+ 'inspect'
+ 'debug'
+ '-'
+ 'resume'
+ 'suspend'
+ 'terminate'
+ '-'
+ 'raise prio'
+ 'lower prio'
+ )
+ selectors:#(
+"/ hideDead:
+"/ nil
+ inspectProcess
+ debugProcess
+ nil
+ resumeProcess
+ suspendProcess
+ terminateProcess
+ nil
+ raisePrio
+ lowerPrio
+ )
+ receiver:self
+ for:listView).
+"/ menu checkToggleAt:#hideDead: put:hideDead.
+ listView middleButtonMenu:menu.
+
listView multipleSelectOk:true.
listView keyboardHandler:self.
updateDelay := 0.5.
listUpdateDelay := 5.
- true "ProcessorScheduler isPureEventDriven" ifTrue:[
- updateBlock := [self updateStatus].
- listUpdateBlock := [self updateList].
+
+ "/ true
+ ProcessorScheduler isPureEventDriven
+ ifTrue:[
+ updateBlock := [self updateStatus].
+ listUpdateBlock := [self updateList].
].
- viewBackground := Black.
+
device hasColors ifTrue:[
- runnableColor := Color green.
- suspendedColor := Color red.
+ runColor := Color green.
+ suspendedColor := Color yellow.
+ waitColor := Color red.
] ifFalse:[
- runnableColor := suspendedColor := Color white
+ runColor := suspendedColor := waitColor := Color black
]
- "ProcessMonitor start"
+ "
+ ProcessMonitor open
+ "
!
realize
super realize.
- self enableKeyEvents.
- self updateList.
- self updateStatus.
+
updateBlock notNil ifTrue:[
- Processor addTimedBlock:updateBlock after:updateDelay.
- Processor addTimedBlock:listUpdateBlock after:listUpdateDelay.
+ Processor addTimedBlock:updateBlock afterSeconds:updateDelay.
+ Processor addTimedBlock:listUpdateBlock afterSeconds:listUpdateDelay.
] ifFalse:[
- updateProcess := [
- [true] whileTrue:[
- 1 to:9 do:[:i |
- (Delay forSeconds:0.5) wait.
- self updateStatus.
- ].
- (Delay forSeconds:0.5) wait.
- self updateList
- ]
- ] forkAt:9.
- updateProcess name:'process update'.
+ updateProcess := [
+ "
+ every half second, the status is updated.
+ every 5 seconds, the list of processes is
+ built up again
+ "
+ [true] whileTrue:[
+ 1 to:9 do:[:i |
+ (Delay forSeconds:0.5) wait.
+ self updateStatus.
+ ].
+ (Delay forSeconds:0.5) wait.
+ self updateList.
+ ]
+ ] forkAt:(Processor userSchedulingPriority + 1).
+ updateProcess name:'process update'.
+ "
+ raise my own priority
+ "
+ Processor activeProcess priority:(Processor userSchedulingPriority + 2)
].
- runnableColor := runnableColor on:device.
+ waitColor := waitColor on:device.
+ runColor := runColor on:device.
suspendedColor := suspendedColor on:device.
+!
+
+mapped
+ super mapped.
+ self updateStatus.
+ self updateList.
! !
!ProcessMonitor methodsFor:'destroying'!
destroy
updateBlock notNil ifTrue:[
- Processor removeTimedBlock:updateBlock.
- Processor removeTimedBlock:listUpdateBlock.
+ Processor removeTimedBlock:updateBlock.
+ Processor removeTimedBlock:listUpdateBlock.
] ifFalse:[
- updateProcess terminate
+ updateProcess terminate
].
super destroy
! !
+!ProcessMonitor methodsFor:'private'!
+
+selectedProcessesDo:aBlock
+ |p nr sel|
+
+ sel := listView selection.
+ sel isNil ifTrue:[^ self].
+ (sel isKindOf:Collection) ifTrue:[
+ sel do:[:n |
+ nr := n - 2. "for headlines"
+ nr notNil ifTrue:[
+ nr > 0 ifTrue:[
+ p := processes at:nr.
+ p notNil ifTrue:[
+ aBlock value:p
+ ]
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ nr := sel - 2. "for headlines"
+ nr notNil ifTrue:[
+ nr > 0 ifTrue:[
+ p := processes at:nr.
+ p notNil ifTrue:[
+ aBlock value:p
+ ]
+ ]
+ ]
+ ].
+! !
+
!ProcessMonitor methodsFor:'menu actions'!
-selectedProcessesDo:aBlock
- |p nr|
-
- (listView selection isKindOf:Collection) ifTrue:[
- listView selection do:[:n |
- nr := n - 2.
- nr notNil ifTrue:[
- nr > 0 ifTrue:[
- p := processes at:nr.
- p notNil ifTrue:[
- aBlock value:p
- ]
- ]
- ]
- ]
- ] ifFalse:[
- nr := listView selection - 2.
- nr notNil ifTrue:[
- nr > 0 ifTrue:[
- p := processes at:nr.
- p notNil ifTrue:[
- aBlock value:p
- ]
- ]
- ]
- ].
+hideDead:aBoolean
+ hideDead := aBoolean
!
debugProcess
@@ -173,6 +220,18 @@
self selectedProcessesDo:[:p |
p suspend
]
+!
+
+raisePrio
+ self selectedProcessesDo:[:p |
+ p priority:(p priority + 1)
+ ]
+!
+
+lowerPrio
+ self selectedProcessesDo:[:p |
+ p priority:(p priority - 1)
+ ]
! !
!ProcessMonitor methodsFor:'events'!
@@ -183,7 +242,7 @@
keyPress:key x:x y:y
key == #InspectIt ifTrue:[
- ^ self inspectProcess.
+ ^ self inspectProcess.
].
^ super keyPress:key x:x y:y
! !
@@ -195,70 +254,111 @@
|newList|
- newList := Process allInstances.
- "sort by id - take core of nil ids of dead processes"
- newList sort:[:p1 :p2 |
- |id1 id2|
+ shown ifTrue:[
+ (Smalltalk at:#SystemDebugging ifAbsent:[false]) ifTrue:[
+ newList := Process allInstances.
+ ] ifFalse:[
+ newList := ProcessorScheduler knownProcesses asOrderedCollection.
+ ].
+
+ "sort by id - take care of nil ids of dead processes"
+ newList sort:[:p1 :p2 |
+ |id1 id2|
- id1 := p1 id.
- id2 := p2 id.
- id1 isNil ifTrue:[true]
- ifFalse:[
- id2 isNil ifTrue:[false]
- ifFalse:[id1 < id2]
- ]
- ].
- newList ~= processes ifTrue:[
- processes := WeakArray withAll:newList.
- self updateStatus
+ (p1 isNil or:[(id1 := p1 id) isNil])
+ ifTrue:[true]
+ ifFalse:[
+ (p2 isNil or:[(id2 := p2 id) isNil])
+ ifTrue:[false]
+ ifFalse:[id1 < id2]
+ ]
+ ].
+ newList ~= processes ifTrue:[
+ processes := WeakArray withAll:newList.
+ self updateStatus
+ ].
].
updateBlock notNil ifTrue:[
- Processor addTimedBlock:listUpdateBlock after:listUpdateDelay
+ Processor addTimedBlock:listUpdateBlock afterSeconds:listUpdateDelay
].
!
updateStatus
"update status display of processes"
- |oldList list line|
+ |oldList list line dIndex con|
- oldList := listView list.
- processes notNil ifTrue:[
- list := OrderedCollection new.
- list add:'name/id state prio usedStack maxStack'.
- list add:'-------------------------------------------------------------------'.
+ shown ifTrue:[
+ oldList := listView list.
+ processes notNil ifTrue:[
+ list := OrderedCollection new.
+ list add:'id name state prio usedStack maxStack'.
+ list add:'-----------------------------------------------------------------'.
- processes do:[:aProcess |
- |nm|
+ dIndex := 1.
+ 1 to:processes size do:[:index |
+ |aProcess nm|
- aProcess notNil ifTrue:[
- nm := aProcess nameOrId.
- nm size > 27 ifTrue:[
- line := (nm copyTo:27) , ' '
- ] ifFalse:[
- line := aProcess nameOrId printStringPaddedTo:28.
- ].
- line := line , (aProcess state printStringPaddedTo:12).
- line := line , (aProcess priority printStringLeftPaddedTo:4).
- line := line , (aProcess usedStackSize printStringLeftPaddedTo:11).
- line := line , (aProcess totalStackSize printStringLeftPaddedTo:10).
- list add:line
- ].
- ].
- ].
- list ~= oldList ifTrue:[
- "avoid flicker"
- oldList size == list size ifTrue:[
- list keysAndValuesDo:[:idx :entry |
- (oldList at:idx) ~= entry ifTrue:[
- listView at:idx put:entry
- ]
- ]
- ] ifFalse:[
- listView setList:list.
- ]
+ aProcess := processes at:index.
+ aProcess notNil ifTrue:[
+ (aProcess id notNil or:[hideDead not]) ifTrue:[
+ line := aProcess id printStringPaddedTo:5.
+ (nm := aProcess name) isNil ifFalse:[
+ nm := nm printString
+ ] ifTrue:[
+ nm := ' '
+ ].
+ nm size >= 26 ifTrue:[
+ nm := (nm copyTo:25) , ' '
+ ] ifFalse:[
+ nm := (nm printStringPaddedTo:26).
+ ].
+ line := line , nm.
+ line := line , (aProcess state printStringPaddedTo:9).
+ line := line , (aProcess priority printStringLeftPaddedTo:3).
+ line := line , (aProcess usedStackSize printStringLeftPaddedTo:11).
+ line := line , (aProcess totalStackSize printStringLeftPaddedTo:10).
+ (Smalltalk at:#SystemDebugging ifAbsent:[false]) ifTrue:[
+ con := aProcess suspendedContext.
+ con isNil ifTrue:[
+ aProcess == Processor activeProcess ifTrue:[
+ con := thisContext
+ ]
+ ].
+ con notNil ifTrue:[
+ line := line , ' '.
+ line := line , ((ObjectMemory addressOf:con) printStringRadix:16).
+ line := line , ' .. '.
+ [con sender notNil] whileTrue:[
+ con := con sender
+ ].
+ line := line , ((ObjectMemory addressOf:con) printStringRadix:16).
+ ]
+ ].
+ list add:line.
+ processes at:dIndex put:aProcess.
+ dIndex := dIndex + 1
+ ]
+ ].
+ ].
+ dIndex to:processes size do:[:index |
+ processes at:index put:nil
+ ]
+ ].
+ list ~= oldList ifTrue:[
+ "avoid flicker"
+ oldList size == list size ifTrue:[
+ list keysAndValuesDo:[:idx :entry |
+ (oldList at:idx) ~= entry ifTrue:[
+ listView at:idx put:entry
+ ]
+ ]
+ ] ifFalse:[
+ listView setList:list.
+ ]
+ ].
].
updateBlock notNil ifTrue:[
- Processor addTimedBlock:updateBlock after:updateDelay
+ Processor addTimedBlock:updateBlock afterSeconds:updateDelay
]
! !
--- a/ProcessMonitor.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ProcessMonitor.st Mon Oct 10 04:16:24 1994 +0100
@@ -1,17 +1,15 @@
StandardSystemView subclass:#ProcessMonitor
- instanceVariableNames:'listView processes listUpdateDelay updateDelay runnableColor suspendedColor
- updateBlock listUpdateBlock updateProcess'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Debugger'
+ instanceVariableNames:'listView processes listUpdateDelay updateDelay
+ updateBlock listUpdateBlock updateProcess hideDead
+ runColor suspendedColor waitColor'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Tools'
!
-ProcessMonitor comment:'
-'!
-
!ProcessMonitor class methodsFor:'startup'!
-start
+open
|m|
m := self new.
@@ -22,127 +20,176 @@
m open.
^ m
- "ProcessMonitor start"
+ "
+ ProcessMonitor open
+ "
! !
!ProcessMonitor methodsFor:'initialization'!
initialize
- |v|
+ |v menu|
super initialize.
- self extent:(font widthOf:'name/id state prio usedStack maxStack')
- + 40 @
- 100.
+ hideDead := true.
+
+ self extent:(font widthOf:'name/id state prio usedStack maxStack')
+ + 40 @
+ 100.
v := ScrollableView for:SelectionInListView in:self.
v origin:0.0@0.0 corner:1.0@1.0.
listView := v scrolledView.
listView font:font.
- listView middleButtonMenu:(PopUpMenu
- labels:#(
- 'inspect'
- 'debug'
- '-'
- 'resume'
- 'suspend'
- 'terminate'
- )
- selectors:#(inspectProcess
- debugProcess
- nil
- resumeProcess
- suspendProcess
- terminateProcess
- )
- receiver:self
- for:listView).
+ menu := (PopUpMenu
+ labels:#(
+"/ hideDead functionality no longer needed;
+"/ since ProcSched knownProcesses only returns living ones
+"/
+"/ '\c hide dead'
+"/ '-'
+ 'inspect'
+ 'debug'
+ '-'
+ 'resume'
+ 'suspend'
+ 'terminate'
+ '-'
+ 'raise prio'
+ 'lower prio'
+ )
+ selectors:#(
+"/ hideDead:
+"/ nil
+ inspectProcess
+ debugProcess
+ nil
+ resumeProcess
+ suspendProcess
+ terminateProcess
+ nil
+ raisePrio
+ lowerPrio
+ )
+ receiver:self
+ for:listView).
+"/ menu checkToggleAt:#hideDead: put:hideDead.
+ listView middleButtonMenu:menu.
+
listView multipleSelectOk:true.
listView keyboardHandler:self.
updateDelay := 0.5.
listUpdateDelay := 5.
- true "ProcessorScheduler isPureEventDriven" ifTrue:[
- updateBlock := [self updateStatus].
- listUpdateBlock := [self updateList].
+
+ "/ true
+ ProcessorScheduler isPureEventDriven
+ ifTrue:[
+ updateBlock := [self updateStatus].
+ listUpdateBlock := [self updateList].
].
- viewBackground := Black.
+
device hasColors ifTrue:[
- runnableColor := Color green.
- suspendedColor := Color red.
+ runColor := Color green.
+ suspendedColor := Color yellow.
+ waitColor := Color red.
] ifFalse:[
- runnableColor := suspendedColor := Color white
+ runColor := suspendedColor := waitColor := Color black
]
- "ProcessMonitor start"
+ "
+ ProcessMonitor open
+ "
!
realize
super realize.
- self enableKeyEvents.
- self updateList.
- self updateStatus.
+
updateBlock notNil ifTrue:[
- Processor addTimedBlock:updateBlock after:updateDelay.
- Processor addTimedBlock:listUpdateBlock after:listUpdateDelay.
+ Processor addTimedBlock:updateBlock afterSeconds:updateDelay.
+ Processor addTimedBlock:listUpdateBlock afterSeconds:listUpdateDelay.
] ifFalse:[
- updateProcess := [
- [true] whileTrue:[
- 1 to:9 do:[:i |
- (Delay forSeconds:0.5) wait.
- self updateStatus.
- ].
- (Delay forSeconds:0.5) wait.
- self updateList
- ]
- ] forkAt:9.
- updateProcess name:'process update'.
+ updateProcess := [
+ "
+ every half second, the status is updated.
+ every 5 seconds, the list of processes is
+ built up again
+ "
+ [true] whileTrue:[
+ 1 to:9 do:[:i |
+ (Delay forSeconds:0.5) wait.
+ self updateStatus.
+ ].
+ (Delay forSeconds:0.5) wait.
+ self updateList.
+ ]
+ ] forkAt:(Processor userSchedulingPriority + 1).
+ updateProcess name:'process update'.
+ "
+ raise my own priority
+ "
+ Processor activeProcess priority:(Processor userSchedulingPriority + 2)
].
- runnableColor := runnableColor on:device.
+ waitColor := waitColor on:device.
+ runColor := runColor on:device.
suspendedColor := suspendedColor on:device.
+!
+
+mapped
+ super mapped.
+ self updateStatus.
+ self updateList.
! !
!ProcessMonitor methodsFor:'destroying'!
destroy
updateBlock notNil ifTrue:[
- Processor removeTimedBlock:updateBlock.
- Processor removeTimedBlock:listUpdateBlock.
+ Processor removeTimedBlock:updateBlock.
+ Processor removeTimedBlock:listUpdateBlock.
] ifFalse:[
- updateProcess terminate
+ updateProcess terminate
].
super destroy
! !
+!ProcessMonitor methodsFor:'private'!
+
+selectedProcessesDo:aBlock
+ |p nr sel|
+
+ sel := listView selection.
+ sel isNil ifTrue:[^ self].
+ (sel isKindOf:Collection) ifTrue:[
+ sel do:[:n |
+ nr := n - 2. "for headlines"
+ nr notNil ifTrue:[
+ nr > 0 ifTrue:[
+ p := processes at:nr.
+ p notNil ifTrue:[
+ aBlock value:p
+ ]
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ nr := sel - 2. "for headlines"
+ nr notNil ifTrue:[
+ nr > 0 ifTrue:[
+ p := processes at:nr.
+ p notNil ifTrue:[
+ aBlock value:p
+ ]
+ ]
+ ]
+ ].
+! !
+
!ProcessMonitor methodsFor:'menu actions'!
-selectedProcessesDo:aBlock
- |p nr|
-
- (listView selection isKindOf:Collection) ifTrue:[
- listView selection do:[:n |
- nr := n - 2.
- nr notNil ifTrue:[
- nr > 0 ifTrue:[
- p := processes at:nr.
- p notNil ifTrue:[
- aBlock value:p
- ]
- ]
- ]
- ]
- ] ifFalse:[
- nr := listView selection - 2.
- nr notNil ifTrue:[
- nr > 0 ifTrue:[
- p := processes at:nr.
- p notNil ifTrue:[
- aBlock value:p
- ]
- ]
- ]
- ].
+hideDead:aBoolean
+ hideDead := aBoolean
!
debugProcess
@@ -173,6 +220,18 @@
self selectedProcessesDo:[:p |
p suspend
]
+!
+
+raisePrio
+ self selectedProcessesDo:[:p |
+ p priority:(p priority + 1)
+ ]
+!
+
+lowerPrio
+ self selectedProcessesDo:[:p |
+ p priority:(p priority - 1)
+ ]
! !
!ProcessMonitor methodsFor:'events'!
@@ -183,7 +242,7 @@
keyPress:key x:x y:y
key == #InspectIt ifTrue:[
- ^ self inspectProcess.
+ ^ self inspectProcess.
].
^ super keyPress:key x:x y:y
! !
@@ -195,70 +254,111 @@
|newList|
- newList := Process allInstances.
- "sort by id - take core of nil ids of dead processes"
- newList sort:[:p1 :p2 |
- |id1 id2|
+ shown ifTrue:[
+ (Smalltalk at:#SystemDebugging ifAbsent:[false]) ifTrue:[
+ newList := Process allInstances.
+ ] ifFalse:[
+ newList := ProcessorScheduler knownProcesses asOrderedCollection.
+ ].
+
+ "sort by id - take care of nil ids of dead processes"
+ newList sort:[:p1 :p2 |
+ |id1 id2|
- id1 := p1 id.
- id2 := p2 id.
- id1 isNil ifTrue:[true]
- ifFalse:[
- id2 isNil ifTrue:[false]
- ifFalse:[id1 < id2]
- ]
- ].
- newList ~= processes ifTrue:[
- processes := WeakArray withAll:newList.
- self updateStatus
+ (p1 isNil or:[(id1 := p1 id) isNil])
+ ifTrue:[true]
+ ifFalse:[
+ (p2 isNil or:[(id2 := p2 id) isNil])
+ ifTrue:[false]
+ ifFalse:[id1 < id2]
+ ]
+ ].
+ newList ~= processes ifTrue:[
+ processes := WeakArray withAll:newList.
+ self updateStatus
+ ].
].
updateBlock notNil ifTrue:[
- Processor addTimedBlock:listUpdateBlock after:listUpdateDelay
+ Processor addTimedBlock:listUpdateBlock afterSeconds:listUpdateDelay
].
!
updateStatus
"update status display of processes"
- |oldList list line|
+ |oldList list line dIndex con|
- oldList := listView list.
- processes notNil ifTrue:[
- list := OrderedCollection new.
- list add:'name/id state prio usedStack maxStack'.
- list add:'-------------------------------------------------------------------'.
+ shown ifTrue:[
+ oldList := listView list.
+ processes notNil ifTrue:[
+ list := OrderedCollection new.
+ list add:'id name state prio usedStack maxStack'.
+ list add:'-----------------------------------------------------------------'.
- processes do:[:aProcess |
- |nm|
+ dIndex := 1.
+ 1 to:processes size do:[:index |
+ |aProcess nm|
- aProcess notNil ifTrue:[
- nm := aProcess nameOrId.
- nm size > 27 ifTrue:[
- line := (nm copyTo:27) , ' '
- ] ifFalse:[
- line := aProcess nameOrId printStringPaddedTo:28.
- ].
- line := line , (aProcess state printStringPaddedTo:12).
- line := line , (aProcess priority printStringLeftPaddedTo:4).
- line := line , (aProcess usedStackSize printStringLeftPaddedTo:11).
- line := line , (aProcess totalStackSize printStringLeftPaddedTo:10).
- list add:line
- ].
- ].
- ].
- list ~= oldList ifTrue:[
- "avoid flicker"
- oldList size == list size ifTrue:[
- list keysAndValuesDo:[:idx :entry |
- (oldList at:idx) ~= entry ifTrue:[
- listView at:idx put:entry
- ]
- ]
- ] ifFalse:[
- listView setList:list.
- ]
+ aProcess := processes at:index.
+ aProcess notNil ifTrue:[
+ (aProcess id notNil or:[hideDead not]) ifTrue:[
+ line := aProcess id printStringPaddedTo:5.
+ (nm := aProcess name) isNil ifFalse:[
+ nm := nm printString
+ ] ifTrue:[
+ nm := ' '
+ ].
+ nm size >= 26 ifTrue:[
+ nm := (nm copyTo:25) , ' '
+ ] ifFalse:[
+ nm := (nm printStringPaddedTo:26).
+ ].
+ line := line , nm.
+ line := line , (aProcess state printStringPaddedTo:9).
+ line := line , (aProcess priority printStringLeftPaddedTo:3).
+ line := line , (aProcess usedStackSize printStringLeftPaddedTo:11).
+ line := line , (aProcess totalStackSize printStringLeftPaddedTo:10).
+ (Smalltalk at:#SystemDebugging ifAbsent:[false]) ifTrue:[
+ con := aProcess suspendedContext.
+ con isNil ifTrue:[
+ aProcess == Processor activeProcess ifTrue:[
+ con := thisContext
+ ]
+ ].
+ con notNil ifTrue:[
+ line := line , ' '.
+ line := line , ((ObjectMemory addressOf:con) printStringRadix:16).
+ line := line , ' .. '.
+ [con sender notNil] whileTrue:[
+ con := con sender
+ ].
+ line := line , ((ObjectMemory addressOf:con) printStringRadix:16).
+ ]
+ ].
+ list add:line.
+ processes at:dIndex put:aProcess.
+ dIndex := dIndex + 1
+ ]
+ ].
+ ].
+ dIndex to:processes size do:[:index |
+ processes at:index put:nil
+ ]
+ ].
+ list ~= oldList ifTrue:[
+ "avoid flicker"
+ oldList size == list size ifTrue:[
+ list keysAndValuesDo:[:idx :entry |
+ (oldList at:idx) ~= entry ifTrue:[
+ listView at:idx put:entry
+ ]
+ ]
+ ] ifFalse:[
+ listView setList:list.
+ ]
+ ].
].
updateBlock notNil ifTrue:[
- Processor addTimedBlock:updateBlock after:updateDelay
+ Processor addTimedBlock:updateBlock afterSeconds:updateDelay
]
! !
--- a/ProjectV.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ProjectV.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,10 +13,10 @@
"
StandardSystemView subclass:#ProjectView
- instanceVariableNames:'myProject toggle'
- classVariableNames:'ActiveProjectView'
- poolDictionaries:''
- category:'Interface-Smalltalk'
+ instanceVariableNames:'myProject toggle'
+ classVariableNames:'ActiveProjectView'
+ poolDictionaries:''
+ category:'Interface-Smalltalk'
!
!ProjectView class methodsFor:'instance creation'!
@@ -44,15 +44,15 @@
myProject := aProject.
e := (toggle width @ toggle height).
drawableId isNil ifTrue:[
- self minExtent:e.
- self maxExtent:e.
- self open
+ self minExtent:e.
+ self maxExtent:e.
+ self open
] ifFalse:[
- self unrealize.
- self minExtent:e.
- self maxExtent:e.
- self extent:e.
- self rerealize
+ self unrealize.
+ self minExtent:e.
+ self maxExtent:e.
+ self extent:e.
+ self rerealize
]
! !
@@ -65,38 +65,38 @@
toggle pressAction:[self showProject].
toggle releaseAction:[self hideProject].
toggle middleButtonMenu:(
- PopUpMenu
- labels:(resources array:
- #('rename'
- 'changes'
- 'directory'
- 'properties'
- '-'
+ PopUpMenu
+ labels:(resources array:
+ #('rename'
+ 'changes'
+ 'directory'
+ 'properties'
+ '-'
"
- 'build'
- '-'
+ 'build'
+ '-'
"
- 'show'
- 'hide'
- '-'
- 'destroy'
- )
- )
- selectors:#(renameProject
- browseChanges
- projectDirectory
- browseProps
- nil
+ 'show'
+ 'hide'
+ '-'
+ 'destroy'
+ )
+ )
+ selectors:#(renameProject
+ browseChanges
+ projectDirectory
+ browseProps
+ nil
"
- buildProject
- nil
+ buildProject
+ nil
"
- showProject
- hideProject
- nil
- destroy
- )
- receiver:self
+ showProject
+ hideProject
+ nil
+ destroy
+ )
+ receiver:self
)
!
@@ -111,37 +111,37 @@
projectDirectory
|box|
- box := EnterBox new.
+ box := FilenameEnterBox new.
box title:'Directory of project:'.
myProject directory notNil ifTrue:[
- box initialText:myProject directory
+ box initialText:myProject directory
].
box action:[:dirName |
- (OperatingSystem isDirectory:dirName) ifFalse:[
- (OperatingSystem isValidPath:dirName) ifTrue:[
- self warn:(resources string:'%1 is not a valid directory' with:dirName).
- ^ self
- ].
- (self confirm:(resources string:'%1 does not exist\\create ?' with:dirName) withCRs) ifTrue:[
- (OperatingSystem recursiveCreateDirectory:dirName) ifFalse:[
- self warn:(resources string:'cannot create %1' with:dirName)
- ]
- ].
- ].
- "did it work ?"
- (OperatingSystem isDirectory:dirName) ifTrue:[
- myProject directory:dirName
- ].
+ (OperatingSystem isDirectory:dirName) ifFalse:[
+ (OperatingSystem isValidPath:dirName) ifTrue:[
+ self warn:(resources string:'%1 is not a valid directory' with:dirName).
+ ^ self
+ ].
+ (self confirm:(resources string:'%1 does not exist\\create ?' with:dirName) withCRs) ifTrue:[
+ (OperatingSystem recursiveCreateDirectory:dirName) ifFalse:[
+ self warn:(resources string:'cannot create %1' with:dirName)
+ ]
+ ].
+ ].
+ "did it work ?"
+ (OperatingSystem isDirectory:dirName) ifTrue:[
+ myProject directory:dirName
+ ].
].
box showAtPointer
!
buildProject
(self confirm:'create files in: ' , myProject directory) ifTrue:[
- myProject createProjectFiles.
- (self confirm:'starting make in: ' , myProject directory) ifTrue:[
- myProject buildProject.
- ].
+ myProject createProjectFiles.
+ (self confirm:'starting make in: ' , myProject directory) ifTrue:[
+ myProject buildProject.
+ ].
].
!
@@ -165,14 +165,14 @@
Do you really want to do this ?'.
box okText:'yes'.
box yesAction:[
- self doDestroyProject
+ self doDestroyProject
].
box showAtPointer
!
showProject
ActiveProjectView notNil ifTrue:[
- ActiveProjectView hideProject
+ ActiveProjectView hideProject
].
ActiveProjectView := self.
@@ -195,8 +195,8 @@
box okText:'rename'.
box initialText:(myProject name).
box action:[:newName |
- myProject name:newName.
- self setProject:myProject
+ myProject name:newName.
+ self setProject:myProject
].
box showAtPointer
!
@@ -218,7 +218,7 @@
Do you really want to do this ?'.
box okText:'yes'.
box yesAction:[
- self doDestroy
+ self doDestroy
].
box showAtPointer
! !
--- a/ProjectView.st Mon Oct 10 04:15:21 1994 +0100
+++ b/ProjectView.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,10 +13,10 @@
"
StandardSystemView subclass:#ProjectView
- instanceVariableNames:'myProject toggle'
- classVariableNames:'ActiveProjectView'
- poolDictionaries:''
- category:'Interface-Smalltalk'
+ instanceVariableNames:'myProject toggle'
+ classVariableNames:'ActiveProjectView'
+ poolDictionaries:''
+ category:'Interface-Smalltalk'
!
!ProjectView class methodsFor:'instance creation'!
@@ -44,15 +44,15 @@
myProject := aProject.
e := (toggle width @ toggle height).
drawableId isNil ifTrue:[
- self minExtent:e.
- self maxExtent:e.
- self open
+ self minExtent:e.
+ self maxExtent:e.
+ self open
] ifFalse:[
- self unrealize.
- self minExtent:e.
- self maxExtent:e.
- self extent:e.
- self rerealize
+ self unrealize.
+ self minExtent:e.
+ self maxExtent:e.
+ self extent:e.
+ self rerealize
]
! !
@@ -65,38 +65,38 @@
toggle pressAction:[self showProject].
toggle releaseAction:[self hideProject].
toggle middleButtonMenu:(
- PopUpMenu
- labels:(resources array:
- #('rename'
- 'changes'
- 'directory'
- 'properties'
- '-'
+ PopUpMenu
+ labels:(resources array:
+ #('rename'
+ 'changes'
+ 'directory'
+ 'properties'
+ '-'
"
- 'build'
- '-'
+ 'build'
+ '-'
"
- 'show'
- 'hide'
- '-'
- 'destroy'
- )
- )
- selectors:#(renameProject
- browseChanges
- projectDirectory
- browseProps
- nil
+ 'show'
+ 'hide'
+ '-'
+ 'destroy'
+ )
+ )
+ selectors:#(renameProject
+ browseChanges
+ projectDirectory
+ browseProps
+ nil
"
- buildProject
- nil
+ buildProject
+ nil
"
- showProject
- hideProject
- nil
- destroy
- )
- receiver:self
+ showProject
+ hideProject
+ nil
+ destroy
+ )
+ receiver:self
)
!
@@ -111,37 +111,37 @@
projectDirectory
|box|
- box := EnterBox new.
+ box := FilenameEnterBox new.
box title:'Directory of project:'.
myProject directory notNil ifTrue:[
- box initialText:myProject directory
+ box initialText:myProject directory
].
box action:[:dirName |
- (OperatingSystem isDirectory:dirName) ifFalse:[
- (OperatingSystem isValidPath:dirName) ifTrue:[
- self warn:(resources string:'%1 is not a valid directory' with:dirName).
- ^ self
- ].
- (self confirm:(resources string:'%1 does not exist\\create ?' with:dirName) withCRs) ifTrue:[
- (OperatingSystem recursiveCreateDirectory:dirName) ifFalse:[
- self warn:(resources string:'cannot create %1' with:dirName)
- ]
- ].
- ].
- "did it work ?"
- (OperatingSystem isDirectory:dirName) ifTrue:[
- myProject directory:dirName
- ].
+ (OperatingSystem isDirectory:dirName) ifFalse:[
+ (OperatingSystem isValidPath:dirName) ifTrue:[
+ self warn:(resources string:'%1 is not a valid directory' with:dirName).
+ ^ self
+ ].
+ (self confirm:(resources string:'%1 does not exist\\create ?' with:dirName) withCRs) ifTrue:[
+ (OperatingSystem recursiveCreateDirectory:dirName) ifFalse:[
+ self warn:(resources string:'cannot create %1' with:dirName)
+ ]
+ ].
+ ].
+ "did it work ?"
+ (OperatingSystem isDirectory:dirName) ifTrue:[
+ myProject directory:dirName
+ ].
].
box showAtPointer
!
buildProject
(self confirm:'create files in: ' , myProject directory) ifTrue:[
- myProject createProjectFiles.
- (self confirm:'starting make in: ' , myProject directory) ifTrue:[
- myProject buildProject.
- ].
+ myProject createProjectFiles.
+ (self confirm:'starting make in: ' , myProject directory) ifTrue:[
+ myProject buildProject.
+ ].
].
!
@@ -165,14 +165,14 @@
Do you really want to do this ?'.
box okText:'yes'.
box yesAction:[
- self doDestroyProject
+ self doDestroyProject
].
box showAtPointer
!
showProject
ActiveProjectView notNil ifTrue:[
- ActiveProjectView hideProject
+ ActiveProjectView hideProject
].
ActiveProjectView := self.
@@ -195,8 +195,8 @@
box okText:'rename'.
box initialText:(myProject name).
box action:[:newName |
- myProject name:newName.
- self setProject:myProject
+ myProject name:newName.
+ self setProject:myProject
].
box showAtPointer
!
@@ -218,7 +218,7 @@
Do you really want to do this ?'.
box okText:'yes'.
box yesAction:[
- self doDestroy
+ self doDestroy
].
box showAtPointer
! !
--- a/SBrowser.st Mon Oct 10 04:15:21 1994 +0100
+++ b/SBrowser.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -14,15 +14,14 @@
StandardSystemView subclass:#SystemBrowser
instanceVariableNames:'classCategoryListView classListView
- methodCategoryListView methodListView
- classMethodListView
- codeView classToggle instanceToggle
- currentClassCategory currentClassHierarchy
- currentClass
- currentMethodCategory currentMethod
- showInstance actualClass fullClass
- enterBox questBox
- selectBox lastMethodCategory'
+ methodCategoryListView methodListView
+ classMethodListView
+ codeView classToggle instanceToggle
+ currentClassCategory currentClassHierarchy
+ currentClass
+ currentMethodCategory currentMethod
+ showInstance actualClass fullClass
+ lastMethodCategory aspect'
classVariableNames:''
poolDictionaries:''
category:'Interface-Browsers'
@@ -30,9 +29,9 @@
SystemBrowser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
-
-$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.12 1994-08-23 23:49:31 claus Exp $
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.13 1994-10-10 03:16:03 claus Exp $
'!
!SystemBrowser class methodsFor:'documentation'!
@@ -40,7 +39,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -53,7 +52,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.12 1994-08-23 23:49:31 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.13 1994-10-10 03:16:03 claus Exp $
"
!
@@ -83,8 +82,8 @@
Does not work currently - still being developped."
^ self newWithLabel:(self classResources string:'System Browser')
- setupBlock:[:browser | browser setupForAll]
- on:aDisplay
+ setupBlock:[:browser | browser setupForAll]
+ on:aDisplay
"
SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
@@ -97,7 +96,7 @@
"launch a browser showing all methods at once"
^ self newWithLabel:'Full Class Browser'
- setupBlock:[:browser | browser setupForFullClass]
+ setupBlock:[:browser | browser setupForFullClass]
"SystemBrowser browseFullClasses"
!
@@ -106,7 +105,7 @@
"launch a browser for all classes under aCategory"
^ self newWithLabel:aClassCategory
- setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
+ setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
"SystemBrowser browseClassCategory:'Kernel-Objects'"
!
@@ -115,7 +114,7 @@
"launch a browser for aClass"
^ self newWithLabel:aClass name
- setupBlock:[:browser | browser setupForClass:aClass]
+ setupBlock:[:browser | browser setupForClass:aClass]
"SystemBrowser browseClass:Object"
!
@@ -124,7 +123,7 @@
"launch a browser for aClass and all its superclasses"
^ self newWithLabel:(aClass name , '-' , 'hierarchy')
- setupBlock:[:browser | browser setupForClassHierarchy:aClass]
+ setupBlock:[:browser | browser setupForClassHierarchy:aClass]
"SystemBrowser browseClassHierarchy:Number"
!
@@ -133,12 +132,12 @@
"launch a browser for all classes in aList"
^ self newWithLabel:title
- setupBlock:[:browser | browser setupForClassList:aList]
+ setupBlock:[:browser | browser setupForClassList:aList]
"
SystemBrowser browseClasses:(Array with:Object
- with:Float)
- title:'two classes'
+ with:Float)
+ title:'two classes'
"
!
@@ -146,7 +145,7 @@
"launch a browser for all methods under aCategory in aClass"
^ self newWithLabel:(aClass name , ' ' , aCategory)
- setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
+ setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
"SystemBrowser browseClass:String methodCategory:'copying'"
!
@@ -155,7 +154,7 @@
"launch a browser for the method at selector in aClass"
^ self newWithLabel:(aClass name , ' ' , selector)
- setupBlock:[:browser | browser setupForClass:aClass selector:selector]
+ setupBlock:[:browser | browser setupForClass:aClass selector:selector]
"SystemBrowser browseClass:Object selector:#printString"
!
@@ -164,17 +163,17 @@
"launch a browser for an explicit list of class/selectors"
(aList size == 0) ifTrue:[
- self showNoneFound:aString.
- ^ nil
+ self showNoneFound:aString.
+ ^ nil
].
aList sort.
^ self newWithLabel:aString
- setupBlock:[:browser | browser setupForList:aList]
+ setupBlock:[:browser | browser setupForList:aList]
"
SystemBrowser browseMethods:#('Object printOn:'
- 'Collection add:')
- title:'some methods'
+ 'Collection add:')
+ title:'some methods'
"
!
@@ -184,9 +183,9 @@
|searchBlock|
aCategory includesMatchCharacters ifTrue:[
- searchBlock := [:c :m :s | aCategory match:m category].
+ searchBlock := [:c :m :s | aCategory match:m category].
] ifFalse:[
- searchBlock := [:c :m :s | m category = aCategory]
+ searchBlock := [:c :m :s | m category = aCategory]
].
self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
@@ -241,43 +240,43 @@
where aBlock evaluates to true.
The block is called with 3 arguments, class, method and seelctor."
- |list prio checkedClasses checkBlock|
+ |list|
"
since this may take a long time, lower my priority ...
"
- prio := Processor activeProcess priority.
- Processor activeProcess priority:(prio - 1).
-
- checkBlock := [:cls |
- |methodArray selectorArray|
-
- (checkedClasses includes:cls) ifFalse:[
- methodArray := cls methodArray.
- selectorArray := cls selectorArray.
-
- 1 to:methodArray size do:[:index |
- |method sel|
-
- method := methodArray at:index.
- sel := selectorArray at:index.
- (aBlock value:cls value:method value:sel) ifTrue:[
- list add:(cls name , ' ' , sel)
- ]
- ].
- checkedClasses add:cls.
- ]
- ].
-
- [
- checkedClasses := IdentitySet new.
- list := OrderedCollection new.
- aCollectionOfClasses do:[:aClass |
- wantInst ifTrue:[checkBlock value:aClass].
- wantClass ifTrue:[checkBlock value:(aClass class)]
- ]
- ] valueNowOrOnUnwindDo:[
- Processor activeProcess priority:prio.
+ Processor activeProcess withLowerPriorityDo:[
+ |checkedClasses checkBlock|
+
+ checkedClasses := IdentitySet new.
+ list := OrderedCollection new.
+
+ checkBlock := [:cls |
+ |methodArray selectorArray|
+
+ (checkedClasses includes:cls) ifFalse:[
+ methodArray := cls methodArray.
+ selectorArray := cls selectorArray.
+
+ 1 to:methodArray size do:[:index |
+ |method sel|
+
+ method := methodArray at:index.
+ sel := selectorArray at:index.
+ (aBlock value:cls value:method value:sel) ifTrue:[
+ list add:(cls name , ' ' , sel)
+ ]
+ ].
+ checkedClasses add:cls.
+ ]
+ ].
+
+ aCollectionOfClasses do:[:aClass |
+"/ Transcript show:'searching '; show:aClass name; showCr:' ...'; endEntry.
+ wantInst ifTrue:[checkBlock value:aClass].
+ wantClass ifTrue:[checkBlock value:(aClass class)].
+ Processor yield
+ ]
].
^ self browseMethods:list title:title
@@ -302,7 +301,7 @@
aCollectionOfClasses where aBlock evaluates to true"
^ self browseMethodsIn:aCollectionOfClasses inst:true class:false
- where:aBlock title:title
+ where:aBlock title:title
! !
!SystemBrowser class methodsFor:'special search startup'!
@@ -316,46 +315,46 @@
list := OrderedCollection new.
((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
- "a matchString"
-
- aCollectionOfClasses do:[:aClass |
- aClass selectorArray do:[:aSelector |
- (aSelectorString match:aSelector) ifTrue:[
- list add:(aClass name , ' ' , aSelector)
- ]
- ].
- aClass class selectorArray do:[:aSelector |
- (aSelectorString match:aSelector) ifTrue:[
- list add:(aClass name , 'class ' , aSelector)
- ]
- ]
- ]
+ "a matchString"
+
+ aCollectionOfClasses do:[:aClass |
+ aClass selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , ' ' , aSelector)
+ ]
+ ].
+ aClass class selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , 'class ' , aSelector)
+ ]
+ ]
+ ]
] ifFalse:[
- "can do a faster search"
-
- aSelectorString knownAsSymbol ifFalse:[
- self showNoneFound:title.
- ^ nil
- ].
-
- sel := aSelectorString asSymbol.
- aCollectionOfClasses do:[:aClass |
- (aClass implements:sel) ifTrue:[
- list add:(aClass name , ' ' , aSelectorString)
- ].
- (aClass class implements:sel) ifTrue:[
- list add:(aClass name , 'class ' , aSelectorString)
- ]
- ]
+ "can do a faster search"
+
+ aSelectorString knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ aCollectionOfClasses do:[:aClass |
+ (aClass implements:sel) ifTrue:[
+ list add:(aClass name , ' ' , aSelectorString)
+ ].
+ (aClass class implements:sel) ifTrue:[
+ list add:(aClass name , 'class ' , aSelectorString)
+ ]
+ ]
].
^ self browseMethods:list title:title
"
SystemBrowser browseImplementorsOf:#+
- in:(Array with:Number
- with:Float
- with:SmallInteger)
- title:'some implementors of +'
+ in:(Array with:Number
+ with:Float
+ with:SmallInteger)
+ title:'some implementors of +'
"
!
@@ -363,8 +362,8 @@
"launch a browser for all implementors of aSelector"
^ self browseImplementorsOf:aSelectorString
- in:(Smalltalk allClasses)
- title:('implementors of: ' , aSelectorString)
+ in:(Smalltalk allClasses)
+ title:('implementors of: ' , aSelectorString)
"
SystemBrowser browseImplementorsOf:#+
@@ -376,10 +375,10 @@
and its subclasses"
^ self browseImplementorsOf:aSelectorString
- in:(aClass withAllSubclasses)
- title:('implementors of: ' ,
- aSelectorString ,
- ' (in or below ' , aClass name , ')')
+ in:(aClass withAllSubclasses)
+ title:('implementors of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
"
SystemBrowser browseImplementorsOf:#+ under:Integer
@@ -392,42 +391,42 @@
|sel browser searchBlock|
((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (aSelectorString match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | searchBlock value:(method literals)]
- title:title
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSelectorString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | searchBlock value:(method literals)]
+ title:title
] ifFalse:[
- aSelectorString knownAsSymbol ifFalse:[
+ aSelectorString knownAsSymbol ifFalse:[
"
- Transcript showCr:'none found.'.
+ Transcript showCr:'none found.'.
"
- self showNoneFound:title.
- ^ nil
- ].
-
- sel := aSelectorString asSymbol.
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | method sends:sel]
- title:title
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | method sends:sel]
+ title:title
].
browser notNil ifTrue:[
- browser setSearchPattern:aSelectorString
+ browser setSearchPattern:aSelectorString
].
^ browser
!
@@ -436,8 +435,8 @@
"launch a browser for all senders of aSelector"
^ self browseAllCallsOn:aSelectorString
- in:(Smalltalk allClasses)
- title:('senders of ' , aSelectorString)
+ in:(Smalltalk allClasses)
+ title:('senders of ' , aSelectorString)
"
SystemBrowser browseAllCallsOn:#+
@@ -448,10 +447,10 @@
"launch a browser for all senders of aSelector in aClass and subclasses"
^ self browseAllCallsOn:aSelectorString
- in:(aClass withAllSubclasses)
- title:('senders of: ' ,
- aSelectorString ,
- ' (in or below ' , aClass name , ')')
+ in:(aClass withAllSubclasses)
+ title:('senders of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
"
SystemBrowser browseAllCallsOn:#+ under:Number
@@ -464,51 +463,51 @@
|browser searchBlock sym|
(aSymbol includesMatchCharacters) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (aSymbol match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSymbol match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
] ifFalse:[
- "
- can do a faster search
- "
- aSymbol knownAsSymbol ifFalse:[
- self showNoneFound:title.
- ^ nil
- ].
-
- sym := aSymbol asSymbol.
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (sym == aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
+ "
+ can do a faster search
+ "
+ aSymbol knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sym := aSymbol asSymbol.
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (sym == aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
].
browser := self browseMethodsWhere:[:c :m :s | searchBlock value:(m literals)] title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aSymbol
+ browser setSearchPattern:aSymbol
].
^ browser
!
@@ -540,52 +539,53 @@
!
browseForString:aString in:aCollectionOfClasses
- "launch a browser for all methods in aCollectionOfClasses containing a string"
+ "launch a browser for all methods in aCollectionOfClasses
+ containing a string-constant"
|browser searchBlock title|
title := 'methods containing: ' , aString displayString.
(aString includesMatchCharacters) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:String) ifTrue:[
- found := (aString match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
] ifFalse:[
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:String) ifTrue:[
- found := (aLiteral = aString)
- ]
- ]
- ]
- ].
- found
- ].
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aLiteral = aString)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
].
browser := self browseMethodsIn:aCollectionOfClasses
- where:[:c :m :s | searchBlock value:(m literals)]
- title:title.
+ where:[:c :m :s | searchBlock value:(m literals)]
+ title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aString
+ browser setSearchPattern:aString
].
^ browser
@@ -612,16 +612,17 @@
list := OrderedCollection new.
^ self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :sel |
- (matchString match:sel) ifTrue:[
- list add:(class name , '>>' , sel)
- ] ifFalse:[
- (matchString match:(method comment)) ifTrue:[
- list add:(class name , '>>' , sel)
- ]
- ]
- ]
- title:('apropos: ' , aString)
+ where:[:class :method :sel |
+ (matchString match:sel) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ] ifFalse:[
+ (matchString match:(method comment)) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ]
+ ].
+ Processor yield.
+ ]
+ title:('apropos: ' , aString)
"SystemBrowser aproposSearch:'append'"
"SystemBrowser aproposSearch:'add'"
@@ -646,44 +647,49 @@
needMatch := varName includesMatchCharacters.
searchBlock := [:c :m :s |
- |src result parser instvars|
-
- src := m source.
- needMatch ifFalse:[
- "
- before doing a slow parse, quickly scan the
- methods source for the variables name ...
- "
- result := (src findString:varName) ~~ 0.
- ] ifTrue:[
- result := true.
- ].
- result ifTrue:[
- result := false.
- parser := Parser parseMethod:src in:c.
- parser notNil ifTrue:[
- modsOnly ifTrue:[
- instvars := parser modifiedInstVars
- ] ifFalse:[
- instvars := parser usedInstVars
- ].
- instvars notNil ifTrue:[
- needMatch ifTrue:[
- instvars do:[:iv |
- (varName match:iv) ifTrue:[result := true]
- ]
- ] ifFalse:[
- result := instvars includes:varName
- ]
- ]
- ]
- ].
- result
+ |src result parser instvars|
+
+ src := m source.
+ src isNil ifTrue:[
+ result := false
+ ] ifFalse:[
+ needMatch ifFalse:[
+ "
+ before doing a slow parse, quickly scan the
+ methods source for the variables name ...
+ "
+ result := (src findString:varName) ~~ 0.
+ ] ifTrue:[
+ result := true.
+ ].
+ result ifTrue:[
+ result := false.
+ parser := Parser parseMethod:src in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ instvars := parser modifiedInstVars
+ ] ifFalse:[
+ instvars := parser usedInstVars
+ ].
+ instvars notNil ifTrue:[
+ needMatch ifTrue:[
+ instvars do:[:iv |
+ (varName match:iv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := instvars includes:varName
+ ]
+ ]
+ ]
+ ].
+ ].
+ Processor yield.
+ result
].
browser := self browseInstMethodsIn:aCollectionOfClasses where:searchBlock title:title.
browser notNil ifTrue:[
- browser setSearchPattern:varName
+ browser setSearchPattern:varName
].
^ browser
!
@@ -696,14 +702,14 @@
|title|
modsOnly ifTrue:[
- title := 'modifications of '
+ title := 'modifications of '
] ifFalse:[
- title := 'references to '
+ title := 'references to '
].
^ self browseInstRefsTo:aString
- in:aCollectionOfClasses
- modificationsOnly:modsOnly
- title:(title , aString)
+ in:aCollectionOfClasses
+ modificationsOnly:modsOnly
+ title:(title , aString)
!
browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
@@ -724,44 +730,49 @@
needMatch := varName includesMatchCharacters.
searchBlock := [:c :m :s |
- |src result parser classvars|
-
- src := m source.
- needMatch ifFalse:[
- "
- before doing a slow parse, quickly scan the
- methods source for the variables name ...
- "
- result := (src findString:varName) ~~ 0.
- ] ifTrue:[
- result := true.
- ].
- result ifTrue:[
- result := false.
- parser := Parser parseMethod:src in:c.
- parser notNil ifTrue:[
- modsOnly ifTrue:[
- classvars := parser modifiedClassVars
- ] ifFalse:[
- classvars := parser usedClassVars
- ].
- classvars notNil ifTrue:[
- needMatch ifTrue:[
- classvars do:[:cv |
- (varName match:cv) ifTrue:[result := true]
- ]
- ] ifFalse:[
- result := classvars includes:varName
- ]
- ]
- ].
- ].
- result
+ |src result parser classvars|
+
+ src := m source.
+ src isNil ifTrue:[
+ result := false
+ ] ifFalse:[
+ needMatch ifFalse:[
+ "
+ before doing a slow parse, quickly scan the
+ methods source for the variables name ...
+ "
+ result := (src findString:varName) ~~ 0.
+ ] ifTrue:[
+ result := true.
+ ].
+ result ifTrue:[
+ result := false.
+ parser := Parser parseMethod:src in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ classvars := parser modifiedClassVars
+ ] ifFalse:[
+ classvars := parser usedClassVars
+ ].
+ classvars notNil ifTrue:[
+ needMatch ifTrue:[
+ classvars do:[:cv |
+ (varName match:cv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := classvars includes:varName
+ ]
+ ]
+ ].
+ ].
+ ].
+ Processor yield.
+ result
].
browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
browser notNil ifTrue:[
- browser setSearchPattern:varName
+ browser setSearchPattern:varName
].
^ browser
!
@@ -774,9 +785,9 @@
|title|
modsOnly ifTrue:[
- title := 'modifications of '
+ title := 'modifications of '
] ifFalse:[
- title := 'references to '
+ title := 'references to '
].
^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
!
@@ -825,10 +836,11 @@
super initialize.
self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
- resolution:100).
+ resolution:100).
showInstance := true.
fullClass := false.
+ aspect := nil.
"inform me, when Smalltalk changes"
Smalltalk addDependent:self
@@ -839,53 +851,47 @@
Smalltalk removeDependent:self.
currentClass notNil ifTrue:[
- currentClass removeDependent:self.
- currentClass := nil
+ currentClass removeDependent:self.
+ currentClass := nil
].
- enterBox notNil ifTrue:[enterBox destroy. enterBox := nil].
- questBox notNil ifTrue:[questBox destroy. questBox := nil].
- selectBox notNil ifTrue:[selectBox destroy. selectBox := nil].
super destroy
!
terminate
(self checkSelectionChangeAllowed) ifTrue:[
- super terminate
+ super terminate
]
!
createTogglesIn:aFrame
"create and setup the class/instance toggles"
- |bw halfSpacing|
+ |halfSpacing h|
instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
- bw := instanceToggle borderWidth.
- halfSpacing := [
- (self is3D and:[style ~~ #st80]) ifTrue:[
- ViewSpacing // 2
- ] ifFalse:[
- 0
- ]
- ].
- instanceToggle extent:[(aFrame width // 2 - halfSpacing value) @ instanceToggle height].
- instanceToggle origin:[bw negated + halfSpacing value
- @
- (aFrame height - instanceToggle heightIncludingBorder + bw)].
+ h := instanceToggle height.
+ instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
+ instanceToggle topInset:(h negated).
instanceToggle turnOn.
instanceToggle pressAction:[self instanceProtocol].
instanceToggle releaseAction:[self classProtocol].
classToggle := Toggle label:(resources at:'class') in:aFrame.
- classToggle extent:[(aFrame width - (aFrame width // 2) - halfSpacing value) @ classToggle height].
- classToggle origin:[(aFrame width // 2 + halfSpacing value)
- @
- (aFrame height - classToggle heightIncludingBorder + bw)].
+ h := classToggle height.
+ classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
+ classToggle topInset:(h negated).
classToggle turnOff.
classToggle pressAction:[self classProtocol].
- classToggle releaseAction:[self instanceProtocol]
+ classToggle releaseAction:[self instanceProtocol].
+
+ StyleSheet is3D ifTrue:[
+ instanceToggle leftInset:(ViewSpacing // 2).
+ classToggle leftInset:(ViewSpacing // 2).
+ instanceToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+ classToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+ ].
!
createClassListViewIn:frame
@@ -898,10 +904,12 @@
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
- @
- (frame height
- - instanceToggle height
- - instanceToggle borderWidth)].
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
classListView := v scrolledView
!
@@ -956,12 +964,12 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
v := HVScrollableView for:SelectionInListView
- miniScrollerH:true miniScrollerV:false
- in:hpanel.
+ miniScrollerH:true miniScrollerV:false
+ in:hpanel.
v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
classCategoryListView := v scrolledView.
"/ classCategoryListView contents:(self listOfAllClassCategories).
@@ -987,8 +995,8 @@
|vpanel hpanel v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
@@ -1014,8 +1022,8 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
@@ -1046,7 +1054,7 @@
|vpanel hpanel frame l v|
vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
@@ -1078,8 +1086,8 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
@@ -1110,8 +1118,8 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
@@ -1121,8 +1129,12 @@
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
- @
- (frame height - instanceToggle heightIncludingBorder)].
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
@@ -1145,8 +1157,8 @@
|vpanel v|
vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
v := ScrollableView for:SelectionInListView in:vpanel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
@@ -1186,9 +1198,9 @@
|vpanel v|
vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
v := ScrollableView for:SelectionInListView in:vpanel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
@@ -1210,43 +1222,43 @@
v := classCategoryListView.
v notNil ifTrue:[
- v action:[:lineNr | self classCategorySelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- v contents:(self listOfAllClassCategories).
- self initializeClassCategoryMenu
+ v action:[:lineNr | self classCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ v contents:(self listOfAllClassCategories).
+ self initializeClassCategoryMenu
].
v := classListView.
v notNil ifTrue:[
- v action:[:lineNr | self classSelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeClassMenu
+ v action:[:lineNr | self classSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMenu
].
v := methodCategoryListView.
v notNil ifTrue:[
- v action:[:lineNr | self methodCategorySelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeMethodCategoryMenu
+ v action:[:lineNr | self methodCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodCategoryMenu
].
v := methodListView.
v notNil ifTrue:[
- v action:[:lineNr | self methodSelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeMethodMenu
+ v action:[:lineNr | self methodSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodMenu
].
v := classMethodListView.
v notNil ifTrue:[
- v action:[:lineNr | self listSelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeClassMethodMenu
+ v action:[:lineNr | self listSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMethodMenu
]
! !
@@ -1260,27 +1272,22 @@
|box|
codeView modified ifFalse:[
- ^ true
- ].
- box := questBox.
- box isNil ifTrue:[
- box := questBox := YesNoBox title:''
+ ^ true
].
-
- box title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs.
- box okText:(resources at:'continue').
- box noText:(resources at:'abort').
- box yesAction:[^ true] noAction:[^ false].
- box showAtPointer
+ box := YesNoBox
+ title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs
+ yesText:(resources at:'continue')
+ noText:(resources at:'abort').
+ ^ box confirm
!
switchToClass:newClass
currentClass notNil ifTrue:[
- currentClass removeDependent:self
+ currentClass removeDependent:self
].
currentClass := newClass.
currentClass notNil ifTrue:[
- currentClass addDependent:self
+ currentClass addDependent:self
]
!
@@ -1301,28 +1308,28 @@
sel := codeView selection.
sel notNil ifTrue:[
- sel := sel asString.
- t := Parser selectorInExpression:sel.
- t notNil ifTrue:[
- sel := t
- ].
- sel := sel withoutSpaces
+ sel := sel asString.
+ t := Parser selectorInExpression:sel.
+ t notNil ifTrue:[
+ sel := t
+ ].
+ sel := sel withoutSpaces
] ifFalse:[
- methodListView notNil ifTrue:[
- sel := methodListView selectionValue
- ] ifFalse:[
- classMethodListView notNil ifTrue:[
- sel := classMethodListView selectionValue.
- sel notNil ifTrue:[
- sel := self selectorFromClassMethodString:sel
- ]
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
+ methodListView notNil ifTrue:[
+ sel := methodListView selectionValue
+ ] ifFalse:[
+ classMethodListView notNil ifTrue:[
+ sel := classMethodListView selectionValue.
+ sel notNil ifTrue:[
+ sel := self selectorFromClassMethodString:sel
+ ]
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
].
^ sel
!
@@ -1334,18 +1341,18 @@
sel := codeView selection.
sel notNil ifTrue:[
- sel := sel asString withoutSpaces
+ sel := sel asString withoutSpaces
] ifFalse:[
- sel isNil ifTrue:[
- currentClass notNil ifTrue:[
- sel := currentClass name
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
+ sel isNil ifTrue:[
+ currentClass notNil ifTrue:[
+ sel := currentClass name
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
].
^ sel
!
@@ -1362,39 +1369,34 @@
"
cls := currentClass.
[cls notNil] whileTrue:[
- ((cls perform:aSelector) includes:aVariableName) ifTrue:[
- homeClass := cls.
- cls := nil.
- ] ifFalse:[
- cls := cls superclass
- ]
+ ((cls perform:aSelector) includes:aVariableName) ifTrue:[
+ homeClass := cls.
+ cls := nil.
+ ] ifFalse:[
+ cls := cls superclass
+ ]
].
homeClass isNil ifTrue:[
- "nope, must be one below ... (could optimize a bit, by searching down
- for the declaring class ...
- "
- homeClass := currentClass
+ "nope, must be one below ... (could optimize a bit, by searching down
+ for the declaring class ...
+ "
+ homeClass := currentClass
] ifFalse:[
- Transcript showCr:'starting search in ' , homeClass name.
+ Transcript showCr:'starting search in ' , homeClass name.
].
^ homeClass
!
listBoxTitle:title okText:okText list:aList
- "convenient method: setup a listBox"
+ "convenient method: setup a listBox & return it"
|box|
- box := selectBox.
- box isNil ifTrue:[
- box := selectBox := ListSelectionBox
- title:''
- okText:(resources string:'ok')
- abortText:(resources string:'abort')
- action:[:aString | ]
- ].
+ box := ListSelectionBox new.
+ box okText:(resources string:okText).
box title:(resources string:title).
box list:aList.
+ ^ box
!
enterBoxTitle:title okText:okText
@@ -1402,83 +1404,88 @@
|box|
- box := enterBox.
- box isNil ifTrue:[
- box := enterBox := EnterBox new
- ].
+ box := EnterBox new.
box title:(resources string:title) okText:(resources string:okText).
- box initialText:''
+ ^ box
+!
+
+askBoxTitle:title okText:okText initialText:initialText action:aBlock
+ "convenient method: setup enterBox, and open it"
+
+ |box|
+
+ box := EnterBox new.
+ box title:(resources string:title) okText:(resources string:okText).
+ box initialText:initialText.
+ box action:[:aString | self withWaitCursorDo:aBlock value:aString].
+ box showAtPointer
!
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
- self enterBoxTitle:title okText:'search'.
- enterBox initialText:(self selectorToSearchFor)
+ |box|
+
+ box := self enterBoxTitle:title okText:'search'.
+ box initialText:(self selectorToSearchFor).
+ ^ box
!
-enterBoxForBrowseSelectorTitle:title
+askAndBrowseSelectorTitle:title action:aBlock
"convenient method: setup enterBox with text from codeView or selected
- method for browsing based on a selector"
-
- self enterBoxTitle:title okText:'browse'.
- enterBox initialText:(self selectorToSearchFor)
+ method for browsing based on a selector. Set action and launch box"
+
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self selectorToSearchFor).
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
!
-enterBoxForBrowseTitle:title
+enterBoxForBrowseTitle:title action:aBlock
"convenient method: setup enterBox with text from codeView or selected
method for method browsing based on className/variable"
- self enterBoxTitle:title okText:'browse'.
- enterBox initialText:(self stringToSearchFor)
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self stringToSearchFor).
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
!
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
- |sel|
-
- self enterBoxTitle:(resources string:title) okText:(resources string:okText).
+ |sel box|
+
+ box := self enterBoxTitle:(resources string:title) okText:(resources string:okText).
sel := codeView selection.
sel notNil ifTrue:[
- enterBox initialText:(sel asString withoutSeparators)
- ] ifFalse:[
- enterBox initialText:nil
- ]
+ box initialText:(sel asString withoutSeparators)
+ ].
+ ^ box
!
-enterBoxForMethodCategory:title
+askAndBrowseMethodCategory:title action:aBlock
"convenient method: setup enterBox with initial being current method category"
- |sel|
-
- self enterBoxTitle:title okText:'browse'.
+ |sel box|
+
+ box := self enterBoxTitle:title okText:'browse'.
sel := codeView selection.
sel isNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- sel := currentMethodCategory
- ]
+ currentMethodCategory notNil ifTrue:[
+ sel := currentMethodCategory
+ ]
].
sel notNil ifTrue:[
- enterBox initialText:(sel asString withoutSpaces)
- ]
-!
-
-newClassCategory:aString
- |categories|
-
- categories := classCategoryListView list.
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- self switchToClass:nil.
- actualClass := nil.
- self classCategorySelectionChanged
- ]
+ box initialText:(sel asString withoutSpaces)
+ ].
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
!
listOfAllClassCategories
@@ -1488,11 +1495,11 @@
newList := Text with:'* all *' with:'* hierarchy *'.
Smalltalk allBehaviorsDo:[:aClass |
- cat := aClass category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- newList indexOf:cat ifAbsent:[newList add:cat]
+ cat := aClass category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ newList indexOf:cat ifAbsent:[newList add:cat]
].
newList sort.
^ newList
@@ -1511,8 +1518,8 @@
theClass := aClass.
newList := Text with:theClass name.
[theClass ~~ Object] whileTrue:[
- theClass := theClass superclass.
- newList add:theClass name
+ theClass := theClass superclass.
+ newList add:theClass name
].
newList reverse.
^ newList
@@ -1526,36 +1533,36 @@
newList := Text new.
(aCategory = '* all *') ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
+ Smalltalk allBehaviorsDo:[:aClass |
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
] ifFalse:[
- (aCategory = '* hierarchy *') ifTrue:[
- classList := Text new.
- self classHierarchyDo:[:aClass :lvl|
- string := aClass name.
- classList indexOf:string ifAbsent:[
- classList add:string.
- newList add:(String new:lvl) , string
- ]
- ].
- ^ newList
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = searchCategory) ifTrue:[
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
- ]
- ]
- ]
+ (aCategory = '* hierarchy *') ifTrue:[
+ classList := Text new.
+ self classHierarchyDo:[:aClass :lvl|
+ string := aClass name.
+ classList indexOf:string ifAbsent:[
+ classList add:string.
+ newList add:(String new:lvl) , string
+ ]
+ ].
+ ^ newList
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = searchCategory) ifTrue:[
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
+ ]
+ ]
+ ]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
@@ -1570,15 +1577,15 @@
classes := Smalltalk allClasses.
classDict := IdentityDictionary new:classes size.
classes do:[:aClass |
- s := aClass superclass.
- s notNil ifTrue:[
- l := classDict at:s ifAbsent:[nil].
- l isNil ifTrue:[
- l := OrderedCollection new:5.
- classDict at:s put:l
- ].
- l add:aClass
- ]
+ s := aClass superclass.
+ s notNil ifTrue:[
+ l := classDict at:s ifAbsent:[nil].
+ l isNil ifTrue:[
+ l := OrderedCollection new:5.
+ classDict at:s put:l
+ ].
+ l add:aClass
+ ]
].
self classHierarchyOf:Object level:0 do:aBlock using:classDict
!
@@ -1592,11 +1599,11 @@
aBlock value:aClass value:level.
subclasses := aDictionary at:aClass ifAbsent:[nil].
(subclasses size == 0) ifFalse:[
- names := subclasses collect:[:class | class name].
- names sortWith:subclasses.
- subclasses do:[:aSubClass |
- self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
- ]
+ names := subclasses collect:[:class | class name].
+ names sortWith:subclasses.
+ subclasses do:[:aSubClass |
+ self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
+ ]
]
!
@@ -1607,11 +1614,11 @@
newList := Text new.
aClass methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
@@ -1625,27 +1632,27 @@
|newList searchCategory selector|
(aCategory = '* all *') ifTrue:[
- newList := aClass selectorArray asText
+ newList := aClass selectorArray asText
] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- newList := Text new.
- aClass methodArray do:[:aMethod |
- (aMethod category = searchCategory) ifTrue:[
- selector := aClass selectorForMethod:aMethod.
- selector notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- selector := selector , ' !!'
- ].
- (newList includes:selector) ifFalse:[
- newList add:selector
- ]
- ]
- ]
- ]
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ (aMethod category = searchCategory) ifTrue:[
+ selector := aClass selectorForMethod:aMethod.
+ selector notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ selector := selector , ' !!'
+ ].
+ (newList includes:selector) ifFalse:[
+ newList add:selector
+ ]
+ ]
+ ]
+ ]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
@@ -1659,21 +1666,21 @@
name := 'NewClass'.
i := 1.
[name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
- i := i + 1.
- name := 'NewClass' , i printString
+ i := i + 1.
+ name := 'NewClass' , i printString
].
aString := className , ' subclass:#' , name , '
- instanceVariableNames: ''''
- classVariableNames: ''''
- poolDictionaries: ''''
- category: '''.
-
- cat notNil ifTrue:[
- aString := aString , cat
- ].
- aString := aString , ''''.
- ^ aString
+ instanceVariableNames: ''''
+ classVariableNames: ''''
+ poolDictionaries: ''''
+ category: '''.
+
+ cat notNil ifTrue:[
+ aString := aString , cat
+ ].
+ aString := aString , ''''.
+ ^ aString
!
template
@@ -1697,35 +1704,35 @@
instanceProtocol
showInstance ifFalse:[
- self checkSelectionChangeAllowed ifTrue:[
- classToggle turnOff.
- instanceToggle turnOn.
- showInstance := true.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOff.
- classToggle turnOn
- ]
+ self checkSelectionChangeAllowed ifTrue:[
+ classToggle turnOff.
+ instanceToggle turnOn.
+ showInstance := true.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOff.
+ classToggle turnOn
+ ]
]
!
classProtocol
showInstance ifTrue:[
- self checkSelectionChangeAllowed ifTrue:[
- instanceToggle turnOff.
- classToggle turnOn.
- showInstance := false.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOn.
- classToggle turnOff
- ]
+ self checkSelectionChangeAllowed ifTrue:[
+ instanceToggle turnOff.
+ classToggle turnOn.
+ showInstance := false.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOn.
+ classToggle turnOff
+ ]
]
!
@@ -1740,39 +1747,39 @@
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
+ oldSelector := methodListView selectionValue
].
classCategoryListView notNil ifTrue:[
- newCategoryList := self listOfAllClassCategories.
- newCategoryList = classCategoryListView list ifFalse:[
- scroll ifTrue:[
- classCategoryListView contents:newCategoryList
- ] ifFalse:[
- classCategoryListView setContents:newCategoryList
- ]
- ]
+ newCategoryList := self listOfAllClassCategories.
+ newCategoryList = classCategoryListView list ifFalse:[
+ scroll ifTrue:[
+ classCategoryListView contents:newCategoryList
+ ] ifFalse:[
+ classCategoryListView setContents:newCategoryList
+ ]
+ ]
].
oldClassCategory notNil ifTrue:[
- classCategoryListView notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ]
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ]
].
classListView notNil ifTrue:[
- oldClass notNil ifTrue:[
- classListView selectElement:(oldClass name)
- ]
+ oldClass notNil ifTrue:[
+ classListView selectElement:(oldClass name)
+ ]
].
oldMethodCategory notNil ifTrue:[
- methodCategoryListView notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
+ methodCategoryListView notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
].
oldSelector notNil ifTrue:[
- methodListView notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
+ methodListView notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
]
!
@@ -1784,30 +1791,30 @@
|classes oldClassName|
classListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- currentClass := Smalltalk at:(oldClassName asSymbol).
- ].
-
- currentClassCategory notNil ifTrue:[
- classes := self listOfAllClassesInCategory:currentClassCategory
- ] ifFalse:[
- currentClassHierarchy notNil ifTrue:[
- classes := self listOfClassHierarchyOf:currentClassHierarchy
- ]
- ].
-
- classListView list = classes ifFalse:[
- scroll ifTrue:[
- classListView contents:classes
- ] ifFalse:[
- classListView setContents:classes
- ].
- oldClassName notNil ifTrue:[
- classListView setContents:classes.
- classListView selectElement:oldClassName
- ].
- ]
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ currentClass := Smalltalk at:(oldClassName asSymbol).
+ ].
+
+ currentClassCategory notNil ifTrue:[
+ classes := self listOfAllClassesInCategory:currentClassCategory
+ ] ifFalse:[
+ currentClassHierarchy notNil ifTrue:[
+ classes := self listOfClassHierarchyOf:currentClassHierarchy
+ ]
+ ].
+
+ classListView list = classes ifFalse:[
+ scroll ifTrue:[
+ classListView contents:classes
+ ] ifFalse:[
+ classListView setContents:classes
+ ].
+ oldClassName notNil ifTrue:[
+ classListView setContents:classes.
+ classListView selectElement:oldClassName
+ ].
+ ]
]
!
@@ -1819,19 +1826,19 @@
|categories|
methodCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInClass:actualClass
- ].
- methodCategoryListView list = categories ifFalse:[
- scroll ifTrue:[
- methodCategoryListView contents:categories
- ] ifFalse:[
- methodCategoryListView setContents:categories
- ].
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
+ currentClass notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInClass:actualClass
+ ].
+ methodCategoryListView list = categories ifFalse:[
+ scroll ifTrue:[
+ methodCategoryListView contents:categories
+ ] ifFalse:[
+ methodCategoryListView setContents:categories
+ ].
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
]
!
@@ -1843,25 +1850,25 @@
|selectors scr first last|
methodListView notNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- ofClass:actualClass
- ].
- scr := scroll.
- first := methodListView firstLineShown.
- first ~~ 1 ifTrue:[
- last := methodListView lastLineShown.
- selectors size <= (last - first + 1) ifTrue:[
- scr := true
- ]
- ].
- methodListView list = selectors ifFalse:[
- scr ifTrue:[
- methodListView contents:selectors
- ] ifFalse:[
- methodListView setContents:selectors
- ]
- ].
+ currentMethodCategory notNil ifTrue:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ ofClass:actualClass
+ ].
+ scr := scroll.
+ first := methodListView firstLineShown.
+ first ~~ 1 ifTrue:[
+ last := methodListView lastLineShown.
+ selectors size <= (last - first + 1) ifTrue:[
+ scr := true
+ ]
+ ].
+ methodListView list = selectors ifFalse:[
+ scr ifTrue:[
+ methodListView contents:selectors
+ ] ifFalse:[
+ methodListView setContents:selectors
+ ]
+ ].
]
!
@@ -1873,36 +1880,36 @@
|code aStream|
fullClass ifTrue:[
- currentClass notNil ifTrue:[
+ currentClass notNil ifTrue:[
" this is too slow for big classes ...
- code := String new:1000.
- aStream := WriteStream on:code.
- currentClass fileOutOn:aStream
+ code := String new:1000.
+ aStream := WriteStream on:code.
+ currentClass fileOutOn:aStream
"
- aStream := FileStream newFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'cannot create temporary file.'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- currentClass fileOutOn:aStream.
- aStream close.
- aStream := FileStream oldFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'oops - cannot reopen temp file'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- code := aStream contents.
- aStream close.
- OperatingSystem removeFile:'__temp'
- ]
+ aStream := FileStream newFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'cannot create temporary file.'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ currentClass fileOutOn:aStream.
+ aStream close.
+ aStream := FileStream oldFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'oops - cannot reopen temp file'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ code := aStream contents.
+ aStream close.
+ OperatingSystem removeFile:'__temp'
+ ]
] ifFalse:[
- currentMethod notNil ifTrue:[
- code := currentMethod source
- ]
+ currentMethod notNil ifTrue:[
+ code := currentMethod source
+ ]
].
codeView contents:code.
codeView modified:false
@@ -1912,80 +1919,80 @@
|oldMethodCategory oldMethod|
self withWaitCursorDo:[
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
-
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
-
- self updateMethodCategoryList.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- methodCategoryListView selection notNil ifTrue:[
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ].
- self updateMethodList.
- self updateCodeView.
-
- fullClass ifTrue:[
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- self compileCode:theCode asString.
- codeView modified:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ] ifFalse:[
- self classDefinition.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- codeView modified:false.
- ].
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ].
- classCategoryListView notNil ifTrue:[
- (currentClassCategory = currentClass category) ifFalse:[
- currentClassCategory := currentClass category.
- classCategoryListView selectElement:currentClassCategory
- ]
- ].
-
- "set self for doits. This allows accessing the current class
- as self, and access to the class variables by name."
-
- codeView doItAction:[:theCode |
- |compiler|
-
- currentClass isNil ifTrue:[
- compiler := Compiler
- ] ifFalse:[
- compiler := currentClass compiler
- ].
- compiler
- evaluate:theCode
- in:nil
- receiver:currentClass
- notifying:codeView
- logged:false
- ifFail:nil
- ]
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateMethodCategoryList.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ methodCategoryListView selection notNil ifTrue:[
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ].
+ self updateMethodList.
+ self updateCodeView.
+
+ fullClass ifTrue:[
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ self compileCode:theCode asString.
+ codeView modified:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ] ifFalse:[
+ self classDefinition.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ codeView modified:false.
+ ].
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ].
+ classCategoryListView notNil ifTrue:[
+ (currentClassCategory = currentClass category) ifFalse:[
+ currentClassCategory := currentClass category.
+ classCategoryListView selectElement:currentClassCategory
+ ]
+ ].
+
+ "set self for doits. This allows accessing the current class
+ as self, and access to the class variables by name."
+
+ codeView doItAction:[:theCode |
+ |compiler|
+
+ currentClass isNil ifTrue:[
+ compiler := Compiler
+ ] ifFalse:[
+ compiler := currentClass compiler
+ ].
+ compiler
+ evaluate:theCode
+ in:nil
+ receiver:currentClass
+ notifying:codeView
+ logged:false
+ ifFail:nil
+ ]
]
!
@@ -1993,18 +2000,18 @@
"class category has changed - update dependant views"
self withWaitCursorDo:[
- self switchToClass:nil.
- actualClass := nil.
- currentMethodCategory := nil.
- currentMethod := nil.
-
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
-
- codeView explainAction:nil.
- codeView acceptAction:nil
+ self switchToClass:nil.
+ actualClass := nil.
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+
+ codeView explainAction:nil.
+ codeView acceptAction:nil
]
!
@@ -2016,29 +2023,29 @@
newCategory := classCategoryListView selectionValue.
(newCategory startsWith:'*') ifTrue:[
- "etiher all or hierarchy;
- remember current selections and switch after showing class list"
- oldClass := currentClass
+ "etiher all or hierarchy;
+ remember current selections and switch after showing class list"
+ oldClass := currentClass
].
currentClassCategory := newCategory.
oldClass isNil ifTrue:[
- self classCategorySelectionChanged
+ self classCategorySelectionChanged
] ifFalse:[
- self withWaitCursorDo:[
- self updateClassList
- ].
- "stupid - search for class name in (indented) list"
- index := 1.
- classListView list do:[:elem |
- (elem endsWith:(oldClass name)) ifTrue:[
- classIndex := index
- ].
- index := index + 1
- ].
- classIndex notNil ifTrue:[
- classListView selection:classIndex.
- self switchToClass:(Smalltalk at:(oldClass name asSymbol))
- ]
+ self withWaitCursorDo:[
+ self updateClassList
+ ].
+ "stupid - search for class name in (indented) list"
+ index := 1.
+ classListView list do:[:elem |
+ (elem endsWith:(oldClass name)) ifTrue:[
+ classIndex := index
+ ].
+ index := index + 1
+ ].
+ classIndex notNil ifTrue:[
+ classListView selection:classIndex.
+ self switchToClass:(Smalltalk at:(oldClass name asSymbol))
+ ]
]
!
@@ -2049,11 +2056,11 @@
classSymbol := classListView selectionValue withoutSpaces asSymbol.
(Smalltalk includesKey:classSymbol) ifTrue:[
- cls := Smalltalk at:classSymbol
+ cls := Smalltalk at:classSymbol
].
cls notNil ifTrue:[
- self switchToClass:cls.
- self classSelectionChanged
+ self switchToClass:cls.
+ self classSelectionChanged
]
!
@@ -2061,32 +2068,32 @@
"method category selection has changed - update dependant views"
self withWaitCursorDo:[
- currentMethod := nil.
-
- self updateMethodList.
- self updateCodeView.
-
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ].
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ]
+ currentMethod := nil.
+
+ self updateMethodList.
+ self updateCodeView.
+
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ].
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ]
]
!
@@ -2103,31 +2110,31 @@
"method selection has changed - update dependant views"
self withWaitCursorDo:[
- self updateCodeView.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ].
- methodListView notNil ifTrue:[
- (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
- self initializeMethodMenu2
- ] ifFalse:[
- self initializeMethodMenu
- ]
- ]
+ self updateCodeView.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ].
+ methodListView notNil ifTrue:[
+ (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
+ self initializeMethodMenu2
+ ] ifFalse:[
+ self initializeMethodMenu
+ ]
+ ]
]
!
@@ -2143,18 +2150,18 @@
kludge: check if its a wrapped one
"
(selectorString endsWith:' !!') ifTrue:[
- selectorString := selectorString copyTo:(selectorString size - 2)
+ selectorString := selectorString copyTo:(selectorString size - 2)
].
selectorSymbol := selectorString asSymbol.
currentMethod := actualClass compiledMethodAt:selectorSymbol.
methodCategoryListView notNil ifTrue:[
- currentMethod notNil ifTrue:[
- (currentMethodCategory = currentMethod category) ifFalse:[
- currentMethodCategory := currentMethod category.
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
+ currentMethod notNil ifTrue:[
+ (currentMethodCategory = currentMethod category) ifFalse:[
+ currentMethodCategory := currentMethod category.
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
].
self methodSelectionChanged
@@ -2187,21 +2194,21 @@
classString := self classFromClassMethodString:string.
selectorString := self selectorFromClassMethodString:string.
((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass class
+ classString := classString copyTo:(classString size - 5).
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass class
] ifFalse:[
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass
].
currentClass isNil ifTrue:[
- self warn:'oops class is gone'
+ self warn:'oops class is gone'
] ifFalse:[
- currentClassCategory := currentClass category.
- currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
- currentMethodCategory := currentMethod category.
-
- self methodSelectionChanged
+ currentClassCategory := currentClass category.
+ currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
+ currentMethodCategory := currentMethod category.
+
+ self methodSelectionChanged
]
! !
@@ -2211,46 +2218,43 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'fileOut each'
+ 'fileOut'
+ 'fileOut each'
"
- 'fileOut binary'
+ 'fileOut binary'
"
- 'printOut'
- 'printOut protocol'
- '-'
- 'spawn'
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- 'rename ...'
- 'remove').
+ 'printOut'
+ 'printOut protocol'
+ '-'
+ 'SPAWN_CATEGORY'
+ 'spawn full class'
+ '-'
+ 'update'
+ 'find class ...'
+ '-'
+ 'new class category ...'
+ 'rename ...'
+ 'remove').
classCategoryListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(classCategoryFileOut
- classCategoryFileOutEach
-"
- classCategoryBinaryFileOut
-"
- classCategoryPrintOut
- classCategoryPrintOutProtocol
- nil
- classCategorySpawn
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- classCategoryRename
- classCategoryRemove)
- receiver:self
- for:classCategoryListView)
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(classCategoryFileOut
+ classCategoryFileOutEach
+ classCategoryPrintOut
+ classCategoryPrintOutProtocol
+ nil
+ classCategorySpawn
+ classCategorySpawnFullClass
+ nil
+ classCategoryUpdate
+ classCategoryFindClass
+ nil
+ classCategoryNewCategory
+ classCategoryRename
+ classCategoryRemove)
+ receiver:self
+ for:classCategoryListView)
!
allClassesInCurrentCategoryInOrderDo:aBlock
@@ -2260,16 +2264,16 @@
|classes|
currentClassCategory notNil ifTrue:[
- classes := OrderedCollection new.
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- classes add:aClass
- ]
- ]
- ].
- classes topologicalSort:[:a :b | b isSubclassOf:a].
- classes do:aBlock
+ classes := OrderedCollection new.
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ classes add:aClass
+ ]
+ ]
+ ].
+ classes topologicalSort:[:a :b | b isSubclassOf:a].
+ classes do:aBlock
]
!
@@ -2278,13 +2282,13 @@
superclasses come first - then subclasses"
currentClassCategory notNil ifTrue:[
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- aBlock value:aClass
- ]
- ]
- ].
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+ ].
]
!
@@ -2294,29 +2298,29 @@
|oldClassName oldMethodCategory|
classCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- (oldClassName endsWith:'-old') ifTrue:[
- oldClassName := oldClassName copyTo:(oldClassName size - 4)
- ]
- ].
- oldMethodCategory := currentMethodCategory.
-
- classCategoryListView setContents:(self listOfAllClassCategories).
- currentClassCategory notNil ifTrue:[
- classCategoryListView selectElement:currentClassCategory.
- self classCategorySelectionChanged.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName.
- self switchToClass:(Smalltalk at:oldClassName asSymbol).
- self classSelectionChanged.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ]
- ]
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ (oldClassName endsWith:'-old') ifTrue:[
+ oldClassName := oldClassName copyTo:(oldClassName size - 4)
+ ]
+ ].
+ oldMethodCategory := currentMethodCategory.
+
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ currentClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:currentClassCategory.
+ self classCategorySelectionChanged.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName.
+ self switchToClass:(Smalltalk at:oldClassName asSymbol).
+ self classSelectionChanged.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ]
+ ]
]
!
@@ -2324,9 +2328,9 @@
|printStream|
self allClassesInCurrentCategoryInOrderDo:[:aClass |
- printStream := Printer new.
- aClass printOutProtocolOn:printStream.
- printStream close
+ printStream := Printer new.
+ aClass printOutProtocolOn:printStream.
+ printStream close
]
!
@@ -2334,20 +2338,18 @@
|printStream|
self allClassesInCurrentCategoryDo:[:aClass |
- printStream := Printer new.
- aClass printOutOn:printStream.
- printStream close
+ printStream := Printer new.
+ aClass printOutOn:printStream.
+ printStream close
]
!
classCategoryFileOut
"create a file 'categoryName' consisting of all classes in current category"
- |aStream fileName project|
-
- currentClassCategory isNil ifTrue:[
- ^ self warn:'select a class category first'.
- ].
+ |aStream fileName|
+
+ self checkClassCategorySelected ifFalse:[^ self].
fileName := currentClassCategory asString.
fileName replaceAll:Character space by:$_.
@@ -2355,38 +2357,41 @@
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
+ fileName := Project currentProjectDirectory , fileName.
].
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
- ^ self warn:(resources string:'cannot create: %1' with:fileName)
+ ^ self warn:'cannot create: %1' with:fileName
].
self withWaitCursorDo:[
- self label:('System Browser writing: ' , fileName).
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass fileOutOn:aStream.
- ].
- aStream close.
- self label:'System Browser'.
+ self label:('System Browser writing: ' , fileName).
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass fileOutOn:aStream.
+ ].
+ aStream close.
+ self label:'System Browser'.
]
!
classCategoryFileOutEach
self withWaitCursorDo:[
- self allClassesInCurrentCategoryDo:[:aClass |
- self label:('System Browser saving: ' , aClass name).
- aClass fileOut
- ].
- self label:'System Browser'.
- ]
-!
-
-classCategoryBinaryFileOut
- self withWaitCursorDo:[
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass binaryFileOut
- ]
+ self allClassesInCurrentCategoryDo:[:aClass |
+ self label:('System Browser saving: ' , aClass name).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ aClass fileOut
+ ]
+ ].
+ self label:'System Browser'.
]
!
@@ -2394,9 +2399,9 @@
"create a new SystemBrowser browsing current classCategory"
currentClassCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClassCategory:currentClassCategory
- ]
+ self withWaitCursorDo:[
+ self class browseClassCategory:currentClassCategory
+ ]
]
!
@@ -2406,20 +2411,36 @@
|newBrowser|
self withWaitCursorDo:[
- newBrowser := self class browseFullClasses
+ newBrowser := self class browseFullClasses
"
- .
- currentClass notNil ifTrue:[
- newBrowser switchToClassNamed:(currentClass name)
- ]
+ .
+ currentClass notNil ifTrue:[
+ newBrowser switchToClassNamed:(currentClass name)
+ ]
"
]
!
classCategoryNewCategory
- self enterBoxTitle:'name of new class category:' okText:'create'.
- enterBox action:[:aString | self newClassCategory:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxTitle:'name of new class category:' okText:'create'.
+ box action:[:aString |
+ |categories|
+
+ categories := classCategoryListView list.
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ self switchToClass:nil.
+ actualClass := nil.
+ self classCategorySelectionChanged
+ ]
+ ].
+ box showAtPointer
!
switchToClassNamed:aString
@@ -2428,50 +2449,53 @@
classSymbol := aString asSymbol.
theClass := Smalltalk at:classSymbol.
theClass isBehavior ifTrue:[
- classCategoryListView notNil ifTrue:[
- currentClassHierarchy isNil ifTrue:[
- (theClass category ~~ currentClassCategory) ifTrue:[
- currentClassCategory := theClass category.
- currentClassCategory isNil ifTrue:[
- classCategoryListView selectElement:'* no category *'
- ] ifFalse:[
- classCategoryListView selectElement:currentClassCategory
- ].
- self classCategorySelectionChanged
- ]
- ]
- ].
- self switchToClass:theClass.
- classListView selectElement:aString.
- self classSelectionChanged
+ classCategoryListView notNil ifTrue:[
+ currentClassHierarchy isNil ifTrue:[
+ (theClass category ~~ currentClassCategory) ifTrue:[
+ currentClassCategory := theClass category.
+ currentClassCategory isNil ifTrue:[
+ classCategoryListView selectElement:'* no category *'
+ ] ifFalse:[
+ classCategoryListView selectElement:currentClassCategory
+ ].
+ self classCategorySelectionChanged
+ ]
+ ]
+ ].
+ self switchToClass:theClass.
+ classListView selectElement:aString.
+ self classSelectionChanged
]
!
switchToClassNameMatching:aMatchString
- |classNames thisName|
+ |classNames thisName box|
classNames := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
- thisName := aClass name.
- (aMatchString match:thisName) ifTrue:[
- classNames add:thisName
- ]
+ thisName := aClass name.
+ (aMatchString match:thisName) ifTrue:[
+ classNames add:thisName
+ ]
].
(classNames size == 0) ifTrue:[^ nil].
(classNames size == 1) ifTrue:[
- ^ self switchToClassNamed:(classNames at:1)
+ ^ self switchToClassNamed:(classNames at:1)
].
- self listBoxTitle:'select class to switch to:'
- okText:'ok'
- list:classNames sort.
- selectBox action:[:aString | self switchToClassNamed:aString].
- selectBox showAtPointer
+
+ box := self listBoxTitle:'select class to switch to:'
+ okText:'ok'
+ list:classNames sort.
+ box action:[:aString | self switchToClassNamed:aString].
+ box showAtPointer
!
classCategoryFindClass
- self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
- enterBox action:[:aString | self switchToClassNameMatching:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
+ box action:[:aString | self switchToClassNameMatching:aString].
+ box showAtPointer
!
renameCurrentClassCategoryTo:aString
@@ -2480,65 +2504,64 @@
|any categories|
currentClassCategory notNil ifTrue:[
- any := false.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- aClass category:aString.
- any := true
- ]
- ].
- any ifFalse:[
- categories := classCategoryListView list.
- categories remove:currentClassCategory.
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- ] ifTrue:[
- currentClassCategory := aString.
- self updateClassCategoryList.
- self updateClassListWithScroll:false
- ]
+ any := false.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ aClass category:aString.
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ categories := classCategoryListView list.
+ categories remove:currentClassCategory.
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ ] ifTrue:[
+ currentClassCategory := aString.
+ self updateClassCategoryList.
+ self updateClassListWithScroll:false
+ ]
]
!
classCategoryRename
"launch an enterBox to rename current class category"
- currentClassCategory isNil ifTrue:[
- ^ self warn:'select a class category first'.
- ].
- self enterBoxTitle:'rename class category to:' okText:'rename'.
- enterBox initialText:currentClassCategory.
- enterBox action:[:aString | self renameCurrentClassCategoryTo:aString].
- enterBox showAtPointer
+ |box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:'rename class category to:' okText:'rename'.
+ box initialText:currentClassCategory.
+ box action:[:aString | self renameCurrentClassCategoryTo:aString].
+ box showAtPointer
!
classCategoryRemove
"remove all classes in current category"
- |count t classesToRemove subclassesRemoved|
-
- currentClassCategory isNil ifTrue:[
- ^ self warn:'select a class category first'.
- ].
+ |count t classesToRemove subclassesRemoved box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
classesToRemove := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- classesToRemove add:aClass
- ]
+ aClass category = currentClassCategory ifTrue:[
+ classesToRemove add:aClass
+ ]
].
subclassesRemoved := OrderedCollection new.
classesToRemove do:[:aClass |
- aClass allSubclassesDo:[:aSubclass |
- (classesToRemove includes:aSubclass) ifFalse:[
- (subclassesRemoved includes:aSubclass) ifFalse:[
- subclassesRemoved add:aSubclass
- ]
- ]
- ]
+ aClass allSubclassesDo:[:aSubclass |
+ (classesToRemove includes:aSubclass) ifFalse:[
+ (subclassesRemoved includes:aSubclass) ifFalse:[
+ subclassesRemoved add:aSubclass
+ ]
+ ]
+ ]
].
count := classesToRemove size.
@@ -2546,9 +2569,9 @@
count ~~ 0 ifTrue:[
t := t , (resources at:'\(with ') , count printString.
count == 1 ifTrue:[
- t := t , (resources at:' class')
+ t := t , (resources at:' class')
] ifFalse:[
- t := t , (resources at:' classes')
+ t := t , (resources at:' classes')
].
t := (t , ')') withCRs
].
@@ -2557,35 +2580,32 @@
count ~~ 0 ifTrue:[
t := t , (resources at:'\(and ') , count printString.
count == 1 ifTrue:[
- t := t , (resources at:' subclass ')
+ t := t , (resources at:' subclass ')
] ifFalse:[
- t := t , (resources at:' subclasses ')
+ t := t , (resources at:' subclasses ')
].
t := (t , ')') withCRs
].
t := t withCRs.
- questBox isNil ifTrue:[questBox := YesNoBox title:''].
- questBox title:t.
- questBox yesAction:[self doRemoveClasses:classesToRemove and:subclassesRemoved].
- questBox okText:(resources at:'remove').
- questBox noText:(resources at:'abort').
- questBox showAtPointer
-!
-
-doRemoveClasses:classList and:subclassList
- "after querying user - do really remove classes in list1 and list2"
-
- subclassList do:[:aClass |
- Smalltalk removeClass:aClass
- ].
- classList do:[:aClass |
- Smalltalk removeClass:aClass
- ].
- currentClassCategory := nil.
- self switchToClass:nil.
- Smalltalk changed
+ box := YesNoBox
+ title:t
+ yesText:(resources at:'remove')
+ noText:(resources at:'abort').
+ box confirm ifTrue:[
+ "after querying user - do really remove classes in list1 and list2"
+
+ subclassesRemoved do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ classesToRemove do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ Smalltalk changed
+ ]
! !
!SystemBrowser methodsFor:'class menu'!
@@ -2594,109 +2614,131 @@
|labels menu|
labels := resources array:#(
- 'fileOut'
-"
- 'fileOut binary'
-"
- 'printOut'
- 'printOut protocol'
- " 'printOut full protocol' "
- '-'
- 'spawn'
- 'spawn hierarchy'
- 'spawn subclasses'
- '-'
- 'hierarchy'
- 'definition'
- 'comment'
- 'class instvars'
- " 'protocols' "
- '-'
- 'variable search'
- '-'
- 'new class'
- 'new subclass'
- 'rename ...'
- 'remove').
+ 'fileOut'
+ 'printOut'
+ 'printOut protocol'
+ " 'printOut full protocol' "
+ '-'
+ 'SPAWN_CLASS'
+ 'spawn hierarchy'
+ 'spawn subclasses'
+ '-'
+ 'hierarchy'
+ 'definition'
+ 'comment'
+ 'class instvars'
+ " 'protocols' "
+ '-'
+ 'variable search'
+ 'class refs'
+ '-'
+ 'new class'
+ 'new subclass'
+ 'rename ...'
+ 'remove').
menu := PopUpMenu labels:labels
- selectors:#(classFileOut
-"
- classBinaryFileOut
-"
- classPrintOut
- classPrintOutProtocol
- " classPrintOutFullProtocol "
- nil
- classSpawn
- classSpawnHierarchy
- classSpawnSubclasses
- nil
- classHierarchy
- classDefinition
- classComment
- classClassInstVars
- " classProtocols "
- nil
-"
- classInstVarRefs
- classClassVarRefs
- classAllInstVarRefs
- classAllClassVarRefs
- nil
- classInstVarMods
- classClassVarMods
- classAllInstVarMods
- classAllClassVarMods
-"
- variables
- nil
- classNewClass
- classNewSubclass
- classRename
- classRemove)
- receiver:self
- for:classListView.
+ selectors:#(classFileOut
+ classPrintOut
+ classPrintOutProtocol
+ " classPrintOutFullProtocol "
+ nil
+ classSpawn
+ classSpawnHierarchy
+ classSpawnSubclasses
+ nil
+ classHierarchy
+ classDefinition
+ classComment
+ classClassInstVars
+ " classProtocols "
+ nil
+ variables
+ classRefs
+ nil
+ classNewClass
+ classNewSubclass
+ classRename
+ classRemove)
+ receiver:self
+ for:classListView.
classListView middleButtonMenu:menu.
menu subMenuAt:#variables
- put:(PopUpMenu labels:(resources array:#(
- 'instvar refs ...'
- 'classvar refs ...'
- 'all instvar refs ...'
- 'all classvar refs ...'
- '-'
- 'instvar mods ...'
- 'classvar mods ...'
- 'all instvar mods ...'
- 'all classvar mods ...'
- ))
- selectors:#(
- classInstVarRefs
- classClassVarRefs
- classAllInstVarRefs
- classAllClassVarRefs
- nil
- classInstVarMods
- classClassVarMods
- classAllInstVarMods
- classAllClassVarMods
- )
- receiver:self
- for:self
-
- ).
+ put:(PopUpMenu labels:(resources array:#(
+ 'instvar refs ...'
+ 'classvar refs ...'
+ 'all instvar refs ...'
+ 'all classvar refs ...'
+ '-'
+ 'instvar mods ...'
+ 'classvar mods ...'
+ 'all instvar mods ...'
+ 'all classvar mods ...'
+ ))
+ selectors:#(
+ classInstVarRefs
+ classClassVarRefs
+ classAllInstVarRefs
+ classAllClassVarRefs
+ nil
+ classInstVarMods
+ classClassVarMods
+ classAllInstVarMods
+ classAllClassVarMods
+ )
+ receiver:self
+ for:self
+
+ ).
+!
+
+checkClassCategorySelected
+ currentClassCategory isNil ifTrue:[
+ self warn:'select a class category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+checkClassSelected
+ currentClass isNil ifTrue:[
+ self warn:'select a class first'.
+ ^ false
+ ].
+ ^ true
+!
+
+checkMethodCategorySelected
+ currentMethodCategory isNil ifTrue:[
+ self warn:'select a method category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+whenMethodCategorySelected:aBlock
+ self checkMethodCategorySelected ifTrue:[
+ self withWaitCursorDo:aBlock
+ ]
+!
+
+checkMethodSelected
+ currentMethod isNil ifTrue:[
+ self warn:'select a method first'.
+ ^ false
+ ].
+ ^ true
!
doClassMenu:aBlock
"a helper - check if class is selected and evaluate aBlock
while showing waitCursor"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self withWaitCursorDo:aBlock
+ self checkClassSelected ifTrue:[
+ self withWaitCursorDo:aBlock
+ ]
!
doClassMenuWithSelection:aBlock
@@ -2709,39 +2751,27 @@
clsName := codeView selection.
clsName notNil ifTrue:[
- clsName := clsName asString withoutSeparators.
- (clsName endsWith:'class') ifTrue:[
- isMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- isMeta := false
- ].
- clsName knownAsSymbol ifTrue:[
- (Smalltalk includesKey:clsName asSymbol) ifTrue:[
- cls := Smalltalk at:clsName asSymbol.
- cls isBehavior ifTrue:[
- isMeta ifTrue:[
- cls := cls class
- ].
- self withWaitCursorDo:[
- aBlock value:cls.
- ].
- ^ self
- ] ifFalse:[
- w := clsName , ' is not a class'
- ]
- ] ifFalse:[
- w := clsName , ' is unknown'
- ].
- self warn:w.
- ^ self
- ].
+ clsName := clsName asString withoutSeparators.
+ (clsName endsWith:'class') ifTrue:[
+ isMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ isMeta := false
+ ].
+ (cls := Smalltalk classNamed:clsName) notNil ifTrue:[
+ isMeta ifTrue:[
+ cls := cls class
+ ].
+ self withWaitCursorDo:[
+ aBlock value:cls.
+ ].
+ ] ifFalse:[
+ self warn:'no class named: %1' with:clsName
+ ].
+ ^ self
].
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self withWaitCursorDo:[aBlock value:currentClass]
+ self doClassMenu:[aBlock value:currentClass]
!
classSpawn
@@ -2751,18 +2781,18 @@
|browser|
self doClassMenuWithSelection:[:cls |
- cls isMeta ifTrue:[
- Smalltalk allClassesDo:[:aClass |
- aClass class == cls ifTrue:[
- browser := self class browseClass:aClass.
- browser classProtocol.
- ^ self
- ].
- ].
- self warn:'oops, no class for this metaclass'.
- ^ self
- ].
- self class browseClass:cls
+ cls isMeta ifTrue:[
+ Smalltalk allClassesDo:[:aClass |
+ aClass class == cls ifTrue:[
+ browser := self class browseClass:aClass.
+ browser classProtocol.
+ ^ self
+ ].
+ ].
+ self warn:'oops, no class for this metaclass'.
+ ^ self
+ ].
+ self class browseClass:cls
]
!
@@ -2770,7 +2800,7 @@
"create a new HierarchyBrowser browsing current class"
self doClassMenuWithSelection:[:cls |
- self class browseClassHierarchy:cls
+ self class browseClassHierarchy:cls
]
!
@@ -2780,10 +2810,10 @@
|subs|
self doClassMenuWithSelection:[:cls |
- subs := cls allSubclasses.
- (subs notNil and:[subs size ~~ 0]) ifTrue:[
- self class browseClasses:subs title:('subclasses of ' , cls name)
- ]
+ subs := cls allSubclasses.
+ (subs notNil and:[subs size ~~ 0]) ifTrue:[
+ self class browseClasses:subs title:('subclasses of ' , cls name)
+ ]
]
!
@@ -2791,9 +2821,9 @@
|printStream|
self doClassMenu:[
- printStream := Printer new.
- currentClass printOutFullProtocolOn:printStream.
- printStream close
+ printStream := Printer new.
+ currentClass printOutFullProtocolOn:printStream.
+ printStream close
]
!
@@ -2801,9 +2831,9 @@
|printStream|
self doClassMenu:[
- printStream := Printer new.
- currentClass printOutProtocolOn:printStream.
- printStream close
+ printStream := Printer new.
+ currentClass printOutProtocolOn:printStream.
+ printStream close
]
!
@@ -2811,23 +2841,22 @@
|printStream|
self doClassMenu:[
- printStream := Printer new.
- currentClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classBinaryFileOut
- self doClassMenu:[
- currentClass binaryFileOut
+ printStream := Printer new.
+ currentClass printOutOn:printStream.
+ printStream close
]
!
classFileOut
self doClassMenu:[
- self label:('System Browser saving: ' , currentClass name).
- currentClass fileOut.
- self label:'System Browser'
+ self label:('System Browser saving: ' , currentClass name).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ currentClass fileOut.
+ ].
+ self label:'System Browser'
]
!
@@ -2837,15 +2866,16 @@
|aStream|
self doClassMenu:[
- aStream := WriteStream on:(String new:200).
- actualClass printHierarchyOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:nil.
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ aStream := WriteStream on:(String new:200).
+ actualClass printHierarchyOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:nil.
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #hierarchy
]
!
@@ -2856,26 +2886,27 @@
|aStream|
self doClassMenu:[
- aStream := WriteStream on:(String new:200).
- currentClass fileOutDefinitionOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- ]
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ aStream := WriteStream on:(String new:200).
+ currentClass fileOutDefinitionOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ ]
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #definition
]
!
@@ -2886,23 +2917,23 @@
|s|
self doClassMenu:[
- s := WriteStream on:(String new).
- currentClass fileOutClassInstVarDefinitionOn:s.
- codeView contents:(s contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- Compiler evaluate:theCode asString notifying:codeView.
- codeView modified:false.
- self updateClassList.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ s := WriteStream on:(String new).
+ currentClass fileOutClassInstVarDefinitionOn:s.
+ codeView contents:(s contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ Compiler evaluate:theCode asString notifying:codeView.
+ codeView modified:false.
+ self updateClassList.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
]
!
@@ -2914,18 +2945,25 @@
"show the classes comment in the codeView"
self doClassMenu:[
- codeView contents:(currentClass comment).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- Object abortSignal catch:[
- currentClass comment:theCode asString.
- codeView modified:false.
- ]
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ codeView contents:(currentClass comment).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ Object abortSignal catch:[
+ currentClass comment:theCode asString.
+ codeView modified:false.
+ ]
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #comment
+ ]
+!
+
+classRefs
+ self doClassMenu:[
+ self class browseReferendsOf:currentClass name asSymbol
]
!
@@ -2933,15 +2971,17 @@
"show an enterbox for instvar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aString |
- self withWaitCursorDo:[
- self class browseInstRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aString |
+ self withWaitCursorDo:[
+ self class browseInstRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
]
!
@@ -2949,29 +2989,31 @@
"show an enterbox for instVar to search for"
self classInstVarRefsOrModsTitle:'instance variable to browse references to:'
- mods:false
+ mods:false
!
classInstVarMods
"show an enterbox for instVar to search for"
self classInstVarRefsOrModsTitle:'instance variable to browse modifications of:'
- mods:true
+ mods:true
!
classClassVarRefsOrModsTitle:title mods:mods
"show an enterbox for classVar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aString |
- self withWaitCursorDo:[
- self class browseClassRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aString |
+ self withWaitCursorDo:[
+ self class browseClassRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
]
!
@@ -2979,33 +3021,35 @@
"show an enterbox for classVar to search for"
self classClassVarRefsOrModsTitle:'class variable to browse modifications of:'
- mods:true
+ mods:true
!
classClassVarRefs
"show an enterbox for classVar to search for"
self classClassVarRefsOrModsTitle:'class variable to browse references to:'
- mods:false
+ mods:false
!
classAllClassOrInstVarRefsTitle:title access:access
"show an enterbox for instVar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aVariableName |
- self withWaitCursorDo:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:false
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:false
+ ]
+ ].
+ box showAtPointer
]
!
@@ -3013,33 +3057,35 @@
"show an enterbox for instVar to search for"
self classAllClassOrInstVarRefsTitle:'instance variable to browse references to:'
- access:#instVarNames
+ access:#instVarNames
!
classAllClassVarRefs
"show an enterbox for classVar to search for"
self classAllClassOrInstVarRefsTitle:'class variable to browse references to:'
- access:#classVarNames
+ access:#classVarNames
!
classAllInstOrClassVarModsTitle:title access:access
"show an enterbox for instVar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aVariableName |
- self withWaitCursorDo:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:true
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:true
+ ]
+ ].
+ box showAtPointer
]
!
@@ -3047,14 +3093,14 @@
"show an enterbox for instVar to search for"
self classAllInstOrClassVarModsTitle:'instance variable to browse modifications of:'
- access:#instVarNames.
+ access:#instVarNames.
!
classAllClassVarMods
"show an enterbox for classVar to search for"
self classAllInstOrClassVarModsTitle:'class variable to browse modifications of:'
- access:#classVarNames.
+ access:#classVarNames.
!
classClassDefinitionTemplateFor:name in:cat
@@ -3067,27 +3113,27 @@
classListView deselect.
fullClass ifFalse:[
- methodCategoryListView contents:nil.
- methodListView contents:nil
+ methodCategoryListView contents:nil.
+ methodListView contents:nil
].
codeView contents:(self templateFor:name in:cat).
codeView modified:false.
codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- |cl|
-
- cl := (Compiler evaluate:theCode asString notifying:codeView).
- cl isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- self switchToClassNamed:(cl name)
- ]
- ].
- codeView cursor:(Cursor normal).
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ |cl|
+
+ cl := (Compiler evaluate:theCode asString notifying:codeView).
+ cl isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ self switchToClassNamed:(cl name)
+ ]
+ ].
+ codeView cursor:(Cursor normal).
].
codeView explainAction:nil.
self switchToClass:nil
@@ -3099,119 +3145,112 @@
|nm|
currentClass notNil ifTrue:[
- nm := currentClass superclass name
+ nm := currentClass superclass name
] ifFalse:[
- nm := 'Object'
+ nm := 'Object'
].
- self classClassDefinitionTemplateFor:nm in:currentClassCategory
+ self classClassDefinitionTemplateFor:nm in:currentClassCategory.
+ aspect := nil
!
classNewSubclass
"create a subclass-definition prototype in codeview"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self classClassDefinitionTemplateFor:(currentClass name)
- in:(currentClass category)
+ self doClassMenu:[
+ self classClassDefinitionTemplateFor:(currentClass name)
+ in:(currentClass category).
+ aspect := nil
+ ]
!
renameCurrentClassTo:aString
"helper - do the rename"
self doClassMenu:[
- |oldName oldSym newSym|
-
- oldName := currentClass name.
- oldSym := oldName asSymbol.
+ |oldName oldSym newSym|
+
+ oldName := currentClass name.
+ oldSym := oldName asSymbol.
"
- currentClass setName:aString.
- newSym := aString asSymbol.
- Smalltalk at:oldSym put:nil.
- Smalltalk removeKey:oldSym.
- Smalltalk at:newSym put:currentClass.
+ currentClass setName:aString.
+ newSym := aString asSymbol.
+ Smalltalk at:oldSym put:nil.
+ Smalltalk removeKey:oldSym.
+ Smalltalk at:newSym put:currentClass.
"
"
- currentClass renameTo:aString.
+ currentClass renameTo:aString.
"
- Smalltalk renameClass:currentClass to:aString.
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self withWaitCursorDo:[
- Transcript showCr:('searching for users of ' , oldSym); endEntry.
- self class browseReferendsOf:oldSym warnIfNone:false
- ]
+ Smalltalk renameClass:currentClass to:aString.
+
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self withWaitCursorDo:[
+ Transcript showCr:('searching for users of ' , oldSym); endEntry.
+ self class browseReferendsOf:oldSym warnIfNone:false
+ ]
]
!
classRename
"launch an enterBox for new name and query user"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
- enterBox initialText:(currentClass name).
- enterBox action:[:aString | self renameCurrentClassTo:aString].
- enterBox showAtPointer
-!
-
-doRemoveCurrentClass
- "after querying user - do really remove current class
- and all subclasses"
-
- self doClassMenu:[
- currentClass allSubclassesDo:[:aSubClass |
- Smalltalk removeClass:aSubClass
- ].
- Smalltalk removeClass:currentClass.
-
- self switchToClass:nil.
- Smalltalk changed.
- self updateClassList.
-
- "if it was the last in its category, update class category list"
-"
- classListView numberOfLines == 0 ifTrue:[
- self updateClassCategoryListWithScroll:false
- ].
-"
- methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
- methodListView notNil ifTrue:[methodListView contents:nil].
- codeView contents:nil.
- codeView modified:false
- ]
+ |box|
+
+ self checkClassSelected ifFalse:[^ self].
+ box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
+ box initialText:(currentClass name).
+ box action:[:aString | self renameCurrentClassTo:aString].
+ box showAtPointer
!
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
- |count t|
+ |count t box|
currentClass notNil ifTrue:[
- count := 0.
- currentClass allSubclassesDo:[:aSubClass |
- count := count + 1
- ].
- t := 'remove ' , currentClass name.
- count ~~ 0 ifTrue:[
- t := t , '\(with ' , count printString.
- count == 1 ifTrue:[
- t := t , ' subclass'
- ] ifFalse:[
- t := t , ' subclasses'
- ].
- t := (t , ')') withCRs
- ].
- questBox isNil ifTrue:[questBox := YesNoBox title:''].
- questBox title:t.
- questBox yesAction:[self doRemoveCurrentClass].
- questBox okText:(resources at:'remove').
- questBox noText:(resources at:'abort').
- questBox showAtPointer
+ count := currentClass allSubclasses size.
+ t := 'remove ' , currentClass name.
+ count ~~ 0 ifTrue:[
+ t := t , '\(with ' , count printString , ' subclass'.
+ count ~~ 1 ifTrue:[
+ t := t , 'es'
+ ].
+ t := (t , ')') withCRs
+ ].
+ box := YesNoBox
+ title:t
+ yesText:(resources at:'remove')
+ noText:(resources at:'abort').
+ box confirm ifTrue:[
+ "after querying user - do really remove current class
+ and all subclasses
+ "
+ self doClassMenu:[
+ currentClass allSubclassesDo:[:aSubClass |
+ Smalltalk removeClass:aSubClass
+ ].
+ Smalltalk removeClass:currentClass.
+
+ self switchToClass:nil.
+ Smalltalk changed.
+ self updateClassList.
+
+ "if it was the last in its category, update class category list"
+"
+ classListView numberOfLines == 0 ifTrue:[
+ self updateClassCategoryListWithScroll:false
+ ].
+"
+ methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
+ methodListView notNil ifTrue:[methodListView contents:nil].
+ codeView contents:nil.
+ codeView modified:false
+ ]
+ ]
]
! !
@@ -3221,75 +3260,75 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'fileOut all'
- 'printOut'
- '-'
- 'spawn'
- 'spawn category'
- '-'
- 'find method here ...'
- 'find method ...'
- '-'
- 'new category ...'
- 'copy category ...'
- 'create access methods'
- 'rename ...'
- 'remove').
+ 'fileOut'
+ 'fileOut all'
+ 'printOut'
+ '-'
+ 'SPAWN_METHODCATEGORY'
+ 'spawn category'
+ '-'
+ 'find method here ...'
+ 'find method ...'
+ '-'
+ 'new category ...'
+ 'copy category ...'
+ 'create access methods'
+ 'rename ...'
+ 'remove').
methodCategoryListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(
- methodCategoryFileOut
- methodCategoryFileOutAll
- methodCategoryPrintOut
- nil
- methodCategorySpawn
- methodCategorySpawnCategory
- nil
- methodCategoryFindMethod
- methodCategoryFindAnyMethod
- nil
- methodCategoryNewCategory
- methodCategoryCopyCategory
- methodCategoryCreateAccessMethods
- methodCategoryRename
- methodCategoryRemove)
- receiver:self
- for:methodCategoryListView)
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ methodCategoryFileOut
+ methodCategoryFileOutAll
+ methodCategoryPrintOut
+ nil
+ methodCategorySpawn
+ methodCategorySpawnCategory
+ nil
+ methodCategoryFindMethod
+ methodCategoryFindAnyMethod
+ nil
+ methodCategoryNewCategory
+ methodCategoryCopyCategory
+ methodCategoryCreateAccessMethods
+ methodCategoryRename
+ methodCategoryRemove)
+ receiver:self
+ for:methodCategoryListView)
!
switchToMethodNamed:matchString
|aSelector method cat index classToSearch selectors|
currentClass notNil ifTrue:[
- showInstance ifTrue:[
- classToSearch := currentClass
- ] ifFalse:[
- classToSearch := currentClass class
- ].
- selectors := classToSearch selectorArray.
-
- ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
- index := selectors findFirst:[:element | matchString match:element]
- ] ifFalse:[
- index := selectors indexOf:matchString
- ].
-
- (index ~~ 0) ifTrue:[
- aSelector := selectors at:index.
- method := classToSearch methodArray at:index.
- cat := method category.
- cat isNil ifTrue:[cat := '* all *'].
- methodCategoryListView selectElement:cat.
- currentMethodCategory := cat.
- self methodCategorySelectionChanged.
-
- currentMethod := classToSearch compiledMethodAt:aSelector.
- methodListView selectElement:aSelector.
- self methodSelectionChanged
- ]
+ showInstance ifTrue:[
+ classToSearch := currentClass
+ ] ifFalse:[
+ classToSearch := currentClass class
+ ].
+ selectors := classToSearch selectorArray.
+
+ ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
+ index := selectors findFirst:[:element | matchString match:element]
+ ] ifFalse:[
+ index := selectors indexOf:matchString
+ ].
+
+ (index ~~ 0) ifTrue:[
+ aSelector := selectors at:index.
+ method := classToSearch methodArray at:index.
+ cat := method category.
+ cat isNil ifTrue:[cat := '* all *'].
+ methodCategoryListView selectElement:cat.
+ currentMethodCategory := cat.
+ self methodCategorySelectionChanged.
+
+ currentMethod := classToSearch compiledMethodAt:aSelector.
+ methodListView selectElement:aSelector.
+ self methodSelectionChanged
+ ]
]
!
@@ -3298,54 +3337,54 @@
aSelector := aString asSymbol.
currentClass isNil ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- classToStartSearch := currentClassHierarchy
- ]
+ currentClassHierarchy notNil ifTrue:[
+ classToStartSearch := currentClassHierarchy
+ ]
] ifFalse:[
- classToStartSearch := currentClass
+ classToStartSearch := currentClass
].
classToStartSearch notNil ifTrue:[
- showInstance ifFalse:[
- classToStartSearch := classToStartSearch class
- ].
- aClass := classToStartSearch whichClassImplements:aSelector.
- aClass notNil ifTrue:[
- nm := aClass name.
- showInstance ifFalse:[
- ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
- nm := nm copyTo:(nm size - 5)
- ]
- ].
- self switchToClassNamed:nm.
- self switchToMethodNamed:aString
- ]
+ showInstance ifFalse:[
+ classToStartSearch := classToStartSearch class
+ ].
+ aClass := classToStartSearch whichClassImplements:aSelector.
+ aClass notNil ifTrue:[
+ nm := aClass name.
+ showInstance ifFalse:[
+ ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
+ nm := nm copyTo:(nm size - 5)
+ ]
+ ].
+ self switchToClassNamed:nm.
+ self switchToMethodNamed:aString
+ ]
]
!
copyMethodsFromClass:aClassName
- |class|
+ |class box|
currentClass notNil ifTrue:[
- Symbol hasInterned:aClassName ifTrue:[:sym |
- (Smalltalk includesKey:sym) ifTrue:[
- class := Smalltalk at:sym
- ].
- ].
- class isBehavior ifFalse:[
- self warn:(resources string:'no class named %1' with:aClassName).
- ^ self
- ].
-
- showInstance ifFalse:[
- class := class class
- ].
-
- "show enterbox for category to copy from"
-
- self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
- okText:'copy'.
- enterBox action:[:aString | self copyMethodsFromClass:class category:aString].
- enterBox showAtPointer
+ Symbol hasInterned:aClassName ifTrue:[:sym |
+ (Smalltalk includesKey:sym) ifTrue:[
+ class := Smalltalk at:sym
+ ].
+ ].
+ class isBehavior ifFalse:[
+ self warn:'no class named %1' with:aClassName.
+ ^ self
+ ].
+
+ showInstance ifFalse:[
+ class := class class
+ ].
+
+ "show enterbox for category to copy from"
+
+ box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
+ okText:'copy'.
+ box action:[:aString | self copyMethodsFromClass:class category:aString].
+ box showAtPointer.
]
!
@@ -3353,50 +3392,49 @@
|source|
currentClass notNil ifTrue:[
- codeView abortAction:[^ self].
- class methodArray do:[:aMethod |
- (category match:aMethod category) ifTrue:[
- source := aMethod source.
- codeView contents:source.
- codeView modified:false.
- actualClass compiler compile:source
- forClass:actualClass
- inCategory:aMethod category
- notifying:codeView.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- ]
- ]
+"/ codeView abortAction:[^ self].
+ Object abortSignal catch:[
+ class methodArray do:[:aMethod |
+ (category match:aMethod category) ifTrue:[
+ source := aMethod source.
+ codeView contents:source.
+ codeView modified:false.
+ actualClass compiler compile:source
+ forClass:actualClass
+ inCategory:aMethod category
+ notifying:codeView.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ ]
+ ]
+ ]
]
!
methodCategoryFindMethod
- self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- enterBox action:[:aString | self switchToMethodNamed:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ box action:[:aString | self switchToMethodNamed:aString].
+ box showAtPointer
!
methodCategoryFindAnyMethod
- self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- enterBox action:[:aString | self switchToAnyMethodNamed:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ box action:[:aString | self switchToAnyMethodNamed:aString].
+ box showAtPointer
!
methodCategoryPrintOut
|printStream|
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
- ].
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- printStream := Printer new.
- actualClass printOutCategory:currentMethodCategory on:printStream.
- printStream close
- ]
+ self checkClassSelected ifFalse:[^ self].
+ self whenMethodCategorySelected:[
+ printStream := Printer new.
+ actualClass printOutCategory:currentMethodCategory on:printStream.
+ printStream close
]
!
@@ -3404,18 +3442,16 @@
"fileOut all methods in the selected methodcategory of
the current class"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
- ].
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
- actualClass fileOutCategory:currentMethodCategory.
- self label:'System Browser'.
- ]
+ self checkClassSelected ifFalse:[^ self].
+ self whenMethodCategorySelected:[
+ self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ actualClass fileOutCategory:currentMethodCategory.
+ ].
+ self label:'System Browser'.
]
!
@@ -3423,49 +3459,61 @@
"fileOut all methods in the selected methodcategory of
the current class"
- |fileName project outStream hasMethodsInThisCategory|
-
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
- ].
- fileName := currentMethodCategory , '.st'.
- fileName replaceAll:Character space by:$_.
- "
- this test allows a smalltalk to be built without Projects/ChangeSets
- "
- Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
- ].
- outStream := FileStream newFileNamed:fileName.
- outStream isNil ifTrue:[
- ^ self warn:(resources string:'cannot create: %1' with:fileName)
- ].
- self withWaitCursorDo:[
- self label:('System Browser saving: ' , currentMethodCategory).
- Smalltalk allClassesDo:[:class |
- hasMethodsInThisCategory := false.
- class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ].
- hasMethodsInThisCategory := false.
- class class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ]
- ].
- outStream close.
- self label:'System Browser'.
+
+ self whenMethodCategorySelected:[
+ |fileName outStream|
+
+ fileName := currentMethodCategory , '.st'.
+ fileName replaceAll:Character space by:$_.
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory , fileName.
+ ].
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ outStream := FileStream newFileNamed:fileName.
+ outStream isNil ifTrue:[
+ ^ self warn:'cannot create: %1' with:fileName
+ ].
+
+ self label:('System Browser saving: ' , currentMethodCategory).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return
+ ] do:[
+ Smalltalk allClassesDo:[:class |
+ |hasMethodsInThisCategory|
+
+ hasMethodsInThisCategory := false.
+ class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ].
+ hasMethodsInThisCategory := false.
+ class class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ]
+ ].
+ ].
+ outStream close.
+ self label:'System Browser'.
].
!
@@ -3473,10 +3521,10 @@
"create a new SystemBrowser browsing current method category"
currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:actualClass
- methodCategory:currentMethodCategory
- ]
+ self withWaitCursorDo:[
+ self class browseClass:actualClass
+ methodCategory:currentMethodCategory
+ ]
]
!
@@ -3484,26 +3532,24 @@
"create a new SystemBrowser browsing all methods from all
classes with same category as current method category"
- self enterBoxForMethodCategory:'category to browse methods:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseMethodCategory:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseMethodCategory:'category to browse methods:'
+ action:[:aString |
+ self class browseMethodCategory:aString
+ ]
!
newMethodCategory:aString
|categories|
currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
+ ^ self warn:'select/create a class first'.
].
categories := methodCategoryListView list.
categories isNil ifTrue:[categories := Text new].
(categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- methodCategoryListView contents:categories
+ categories add:aString.
+ categories sort.
+ methodCategoryListView contents:categories
].
currentMethodCategory := aString.
self methodCategorySelectionChanged
@@ -3512,34 +3558,34 @@
methodCategoryNewCategory
"show the enter box to add a new method category"
- |someCategories existingCategories|
+ |someCategories existingCategories box|
"a tiny little goody here ..."
showInstance ifTrue:[
- someCategories := #('accessing'
- 'initialization'
- 'private'
- 'printing & storing'
- 'queries'
- 'testing'
- )
+ someCategories := #('accessing'
+ 'initialization'
+ 'private'
+ 'printing & storing'
+ 'queries'
+ 'testing'
+ )
] ifFalse:[
- someCategories := #(
- 'documentation'
- 'initialization'
- 'instance creation'
- ).
+ someCategories := #(
+ 'documentation'
+ 'initialization'
+ 'instance creation'
+ ).
].
existingCategories := methodCategoryListView list.
existingCategories notNil ifTrue:[
- someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
+ someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
].
- self listBoxTitle:(resources at:'name of new method category:')
- okText:(resources at:'create')
- list:someCategories.
- selectBox action:[:aString | self newMethodCategory:aString].
- selectBox showAtPointer
+ box := self listBoxTitle:'name of new method category:'
+ okText:'create'
+ list:someCategories.
+ box action:[:aString | self newMethodCategory:aString].
+ box showAtPointer
!
methodCategoryCreateAccessMethods
@@ -3547,133 +3593,116 @@
|source|
- currentClass isNil ifTrue:[^ self].
+ self checkClassSelected ifFalse:[^ self].
+
showInstance ifFalse:[
- self warn:(resources string:'select instance - and try again').
- ^ self.
+ self warn:'select instance - and try again'.
+ ^ self.
].
+
self withWaitCursorDo:[
- currentClass instVarNames do:[:name |
- "check, if method is not already present"
- (currentClass implements:(name asSymbol)) ifFalse:[
- source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ''' already present'
- ].
- (currentClass implements:((name , ':') asSymbol)) ifFalse:[
- source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ':'' already present'
- ].
- ].
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
+ currentClass instVarNames do:[:name |
+ "check, if method is not already present"
+ (currentClass implements:(name asSymbol)) ifFalse:[
+ source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ''' already present'
+ ].
+ (currentClass implements:((name , ':') asSymbol)) ifFalse:[
+ source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ':'' already present'
+ ].
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
]
!
methodCategoryCopyCategory
"show the enter box to copy from an existing method category"
- |title|
+ |title box|
showInstance ifTrue:[
- title := 'class to copy instance method category from:'
+ title := 'class to copy instance method category from:'
] ifFalse:[
- title := 'class to copy class method category from:'
+ title := 'class to copy class method category from:'
].
- self listBoxTitle:title
- okText:'ok'
- list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
-
- selectBox action:[:aString | self copyMethodsFromClass:aString].
- selectBox showAtPointer
-!
-
-renameCurrentMethodCategoryTo:aString
- "helper - do the rename"
-
- currentMethodCategory notNil ifTrue:[
- actualClass renameCategory:currentMethodCategory to:aString.
-
-"/ actualClass methodArray do:[:aMethod |
-"/ aMethod category = currentMethodCategory ifTrue:[
-"/ aMethod category:aString
-"/ ]
-"/ ].
- currentMethodCategory := aString.
- currentMethod := nil.
- self updateMethodCategoryList.
- self updateMethodListWithScroll:false
- ]
+ box := self listBoxTitle:title
+ okText:'ok'
+ list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
+
+ box action:[:aString | self copyMethodsFromClass:aString].
+ box showAtPointer
!
methodCategoryRename
"launch an enterBox to rename current method category"
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
+ |box|
+
+ self checkMethodCategorySelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
+ okText:(resources at:'rename').
+ box initialText:currentMethodCategory.
+ box action:[:aString |
+ actualClass renameCategory:currentMethodCategory to:aString.
+ currentMethodCategory := aString.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodListWithScroll:false
].
-
- self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
- okText:(resources at:'rename').
- enterBox initialText:currentMethodCategory.
- enterBox action:[:aString | self renameCurrentMethodCategoryTo:aString].
- enterBox showAtPointer
-!
-
-doMethodCategoryRemove
- "actually remove all methods from current method category"
-
- currentMethodCategory notNil ifTrue:[
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- actualClass
- removeSelector:(actualClass selectorForMethod:aMethod)
- ]
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
- self updateMethodCategoryList.
- self updateMethodList
- ]
+ box showAtPointer
!
methodCategoryRemove
"show number of methods to remove and query user"
- |count t|
+ |count t box|
currentMethodCategory notNil ifTrue:[
- count := 0.
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- count := count + 1
- ]
- ].
- (count == 0) ifTrue:[
- currentMethodCategory := nil.
- currentMethod := nil.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodList
- ] ifFalse:[
- (count == 1) ifTrue:[
- t := resources string:'remove %1 ?\(with 1 method)' with:currentMethodCategory
- ] ifFalse:[
- t := resources string:'remove %1 ?\(with %2 methods)' with:currentMethodCategory
- with:count printString.
- ].
- t := t withCRs.
-
- questBox isNil ifTrue:[questBox := YesNoBox title:''].
- questBox title:t.
- questBox yesAction:[self doMethodCategoryRemove].
- questBox okText:(resources at:'remove').
- questBox noText:(resources at:'abort').
- questBox showAtPointer
- ]
+ count := 0.
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ count := count + 1
+ ]
+ ].
+ (count == 0) ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodList
+ ] ifFalse:[
+ (count == 1) ifTrue:[
+ t := resources string:'remove %1 ?\(with 1 method)' with:currentMethodCategory
+ ] ifFalse:[
+ t := resources string:'remove %1 ?\(with %2 methods)' with:currentMethodCategory
+ with:count printString.
+ ].
+ t := t withCRs.
+
+ box := YesNoBox
+ title:t
+ yesText:(resources at:'remove')
+ noText:(resources at:'abort').
+ box confirm ifTrue:[
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ actualClass
+ removeSelector:(actualClass selectorForMethod:aMethod)
+ ]
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodList
+ ]
+ ]
]
! !
@@ -3683,64 +3712,64 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'printOut'
- '-'
- 'spawn'
- '-'
- 'senders ...'
- 'implementors ...'
- 'globals ...'
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
"
- 'strings ...'
- 'apropos ...'
+ 'strings ...'
+ 'apropos ...'
"
- '-'
- 'local senders ...'
- 'local implementors ...'
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
"
- 'local strings ...'
+ 'local strings ...'
"
- '-'
- 'breakpoint'
- 'trace'
- 'trace sender'
- '-'
- 'new method'
- 'change category ...'
- 'remove').
+ '-'
+ 'breakpoint'
+ 'trace'
+ 'trace sender'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
methodListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
"
- methodStringSearch
- methodAproposSearch
+ methodStringSearch
+ methodAproposSearch
"
- nil
- methodLocalSenders
- methodLocalImplementors
+ nil
+ methodLocalSenders
+ methodLocalImplementors
"
- methodLocalStringSearch
+ methodLocalStringSearch
"
- nil
- methodBreakPoint
- methodTrace
- methodTraceSender
- nil
- methodNewMethod
- methodChangeCategory
- methodRemove)
- receiver:self
- for:methodListView)
+ nil
+ methodBreakPoint
+ methodTrace
+ methodTraceSender
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
!
initializeMethodMenu2
@@ -3748,60 +3777,60 @@
methodListView isNil ifTrue:[^ self].
labels := resources array:#(
- 'fileOut'
- 'printOut'
- '-'
- 'spawn'
- '-'
- 'senders ...'
- 'implementors ...'
- 'globals ...'
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
"
- 'strings ...'
- 'apropos ...'
+ 'strings ...'
+ 'apropos ...'
"
- '-'
- 'local senders ...'
- 'local implementors ...'
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
"
- 'local strings ...'
+ 'local strings ...'
"
- '-'
- 'remove break/trace'
- '-'
- 'new method'
- 'change category ...'
- 'remove').
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
methodListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
"
- methodStringSearch
- methodAproposSearch
+ methodStringSearch
+ methodAproposSearch
"
- nil
- methodLocalSenders
- methodLocalImplementors
+ nil
+ methodLocalSenders
+ methodLocalImplementors
"
- methodLocalStringSearch
+ methodLocalStringSearch
"
- nil
- methodRemoveBreakOrTrace
- nil
- methodNewMethod
- methodChangeCategory
- methodRemove)
- receiver:self
- for:methodListView)
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
!
methodPrintOut
@@ -3809,9 +3838,8 @@
|printStream|
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
+ self checkMethodSelected ifFalse:[^ self].
+
printStream := Printer new.
actualClass printOutSource:currentMethod source on:printStream.
printStream close
@@ -3820,110 +3848,91 @@
methodFileOut
"file out the current method"
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
+ self checkMethodSelected ifFalse:[^ self].
+
+ self label:'System Browser saving'.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return
+ ] do:[
+ actualClass fileOutMethod:currentMethod.
].
- self label:'System Browser saving'.
- actualClass fileOutMethod:currentMethod.
self label:'System Browser'.
!
methodImplementors
"launch an enterBox for selector to search for"
- self enterBoxForBrowseSelectorTitle:'selector to browse implementors of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseImplementorsOf:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'selector to browse implementors of:'
+ action:[:aString |
+ self class browseImplementorsOf:aString
+ ]
!
methodLocalImplementors
"launch an enterBox for selector to search for"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
-
- self enterBoxForBrowseSelectorTitle:'selector to browse local implementors of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseImplementorsOf:aString under:currentClass
- ]
- ].
- enterBox showAtPointer
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'selector to browse local implementors of:'
+ action:[:aString |
+ self class browseImplementorsOf:aString under:currentClass
+ ]
!
methodSenders
"launch an enterBox for selector to search for"
- self enterBoxForBrowseSelectorTitle:'selector to browse senders of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseAllCallsOn:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'selector to browse senders of:'
+ action:[:aString |
+ self class browseAllCallsOn:aString
+ ]
!
methodLocalSenders
"launch an enterBox for selector to search for in current class & subclasses"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self enterBoxForBrowseSelectorTitle:'selector to browse local senderss of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseCallsOn:aString under:currentClass
- ]
- ].
- enterBox showAtPointer
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'selector to browse local senderss of:'
+ action:[:aString |
+ self class browseCallsOn:aString under:currentClass
+ ]
!
methodGlobalReferends
"launch an enterBox for global symbol to search for"
- self enterBoxForBrowseTitle:'global variable to browse users of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseReferendsOf:aString asSymbol
- ]
- ].
- enterBox showAtPointer
+ self enterBoxForBrowseTitle:'global variable to browse users of:'
+ action:[:aString |
+ self class browseReferendsOf:aString asSymbol
+ ]
!
methodStringSearch
"launch an enterBox for (sub)-string to search for"
- self enterBoxForBrowseSelectorTitle:'string / matchString to search for:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseForString:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'string / matchString to search for:'
+ action:[:aString |
+ self class browseForString:aString
+ ]
!
methodLocalStringSearch
"launch an enterBox for (sub)-string to search for"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self enterBoxForBrowseSelectorTitle:'string / matchString to search for locally:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseForString:aString in:(currentClass withAllSubclasses)
- ]
- ].
- enterBox showAtPointer
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'string / matchString to search for locally:'
+ action:[:aString |
+ self class browseForString:aString in:(currentClass withAllSubclasses)
+ ]
!
methodAproposSearch
"launch an enterBox for a keyword search"
- self enterBoxForBrowseSelectorTitle:'keyword to search for:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class aproposSearch:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'keyword to search for:'
+ action:[:aString |
+ self class aproposSearch:aString
+ ]
!
methodSpawn
@@ -3931,74 +3940,76 @@
or if the current selection is of the form 'class>>selector', spwan
a browser on that method."
- |s sel clsName cls browseMeta w sep|
+ |s sel selSymbol clsName clsSymbol cls meta browseMeta w sep|
sel := codeView selection.
sel notNil ifTrue:[
- sel := sel asString withoutSeparators.
- ('*>>*' match:sel) ifTrue:[
- sep := $>
- ] ifFalse:[
- ('* *' match:sel) ifTrue:[
- sep := Character space
- ]
- ].
- sep notNil ifTrue:[
- s := ReadStream on:sel.
- clsName := s upTo:sep.
- [s peek == sep] whileTrue:[s next].
- sel := s upToEnd.
- (clsName endsWith:'class') ifTrue:[
- browseMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- browseMeta := false
- ].
- (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
- (Smalltalk includesKey:clsName asSymbol) ifTrue:[
- cls := Smalltalk at:clsName asSymbol.
- browseMeta ifTrue:[
- cls := cls class
- ].
- cls isBehavior ifFalse:[
- cls := cls class
- ].
- cls isBehavior ifTrue:[
- (cls implements:sel asSymbol) ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:cls selector:sel asSymbol
- ].
- ^ self
- ] ifFalse:[
- (cls class implements:sel asSymbol) ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:cls class selector:sel asSymbol
- ].
- ^ self
- ] ifFalse:[
- w := clsName , ' does not implement #' , sel
- ]
- ]
- ] ifFalse:[
- w := clsName , ' is not a class'
- ]
- ] ifFalse:[
- w := clsName , ' is unknown'
- ]
- ] ifFalse:[
- w := clsName , ' and/or ' , sel , ' is unknown'
- ].
- self warn:w.
- ^ self
- ].
+ sel := sel asString withoutSeparators.
+ ('*>>*' match:sel) ifTrue:[
+ sep := $>
+ ] ifFalse:[
+ ('* *' match:sel) ifTrue:[
+ sep := Character space
+ ]
+ ].
+ sep notNil ifTrue:[
+ "
+ extract class/sel from selection
+ "
+ s := ReadStream on:sel.
+ clsName := s upTo:sep.
+ [s peek == sep] whileTrue:[s next].
+ sel := s upToEnd.
+
+ (clsName endsWith:'class') ifTrue:[
+ browseMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ browseMeta := false
+ ].
+ (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
+ clsSymbol := clsName asSymbol.
+ (Smalltalk includesKey:clsSymbol) ifTrue:[
+ cls := Smalltalk at:clsSymbol.
+ browseMeta ifTrue:[
+ cls := cls class
+ ].
+ cls isBehavior ifFalse:[
+ cls := cls class
+ ].
+ cls isBehavior ifTrue:[
+ selSymbol := sel asSymbol.
+ self withWaitCursorDo:[
+ (cls implements:selSymbol) ifTrue:[
+ self class browseClass:cls selector:selSymbol.
+ ^ self
+ ] ifFalse:[
+ meta := cls class.
+ (meta implements:selSymbol) ifTrue:[
+ self class browseClass:meta selector:selSymbol.
+ ^ self
+ ].
+ w := ' does not implement #' , sel
+ ]
+ ]
+ ] ifFalse:[
+ w := ' is not a class'
+ ]
+ ] ifFalse:[
+ w := ' is unknown'
+ ]
+ ] ifFalse:[
+ w := ' and/or ' , sel , ' is unknown'
+ ].
+ self warn:(clsName , w).
+ ^ self
+ ].
].
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
+ self checkMethodSelected ifFalse:[^ self].
self withWaitCursorDo:[
- self class browseClass:actualClass
- selector:(actualClass selectorForMethod:currentMethod)
+ self class browseClass:actualClass
+ selector:(actualClass selectorForMethod:currentMethod)
]
!
@@ -4007,10 +4018,10 @@
code view and define accept-action to compile it"
currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
+ ^ self warn:'select/create a class first'.
].
currentMethodCategory isNil ifTrue:[
- ^ self warn:'select/create a method category first'.
+ ^ self warn:'select/create a method category first'.
].
currentMethod := nil.
@@ -4020,44 +4031,29 @@
codeView modified:false.
codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
]
!
methodRemove
"remove the current method"
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
- actualClass
- removeSelector:(actualClass selectorForMethod:currentMethod).
- self updateMethodListWithScroll:false
-!
-
-doChangeCategoryOfCurrentMethodTo:aString
- "after querying user - do really change current methods category"
-
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
- currentMethod category:aString asSymbol.
- currentClass changed.
- self updateMethodCategoryListWithScroll:false.
+ self checkMethodSelected ifFalse:[^ self].
+ actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
self updateMethodListWithScroll:false
!
@@ -4066,20 +4062,27 @@
nothing done here, but a query for the new category.
Remember the last category, to allow faster category change of a group of methods."
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
- self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
- okText:'change'.
+ |box txt|
+
+ self checkMethodSelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
+ okText:'change'.
lastMethodCategory isNil ifTrue:[
- enterBox initialText:(currentMethod category).
+ txt := currentMethod category.
] ifFalse:[
- enterBox initialText:lastMethodCategory
+ txt := lastMethodCategory
].
- enterBox action:[:aString | lastMethodCategory := aString.
- self doChangeCategoryOfCurrentMethodTo:aString
- ].
- enterBox showAtPointer
+ box initialText:txt.
+ box action:[:aString |
+ lastMethodCategory := aString.
+
+ currentMethod category:aString asSymbol.
+ currentClass changed.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+ ].
+ box showAtPointer
!
methodRemoveBreakOrTrace
@@ -4088,13 +4091,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifTrue:[
- currentMethod := MessageTracer unwrapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- self initializeMethodMenu
- ].
+ currentMethod isWrapped ifTrue:[
+ currentMethod := MessageTracer unwrapMethod:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ self initializeMethodMenu
+ ].
]
!
@@ -4104,13 +4107,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer trapMethod:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer trapMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
]
!
@@ -4120,13 +4123,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethod:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
]
!
@@ -4136,13 +4139,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethodSender:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethodSender:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
]
! !
@@ -4152,40 +4155,118 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'printOut'
- '-'
- 'spawn'
- 'spawn class'
- '-'
- 'sender ...'
- 'implementors ...'
- 'globals ...'
+ 'fileOut'
+ 'fileOut all'
+ 'printOut'
+ '-'
+ 'spawn'
+ 'spawn class'
+ '-'
+ 'sender ...'
+ 'implementors ...'
+ 'globals ...'
"/ '-'
"/ 'breakpoint'
"/ 'trace'
"/ 'trace sender'
- ).
+ ).
classMethodListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(methodFileOut
- methodPrintOut
- nil
- methodSpawn
- classSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ classMethodFileOutAll
+ methodPrintOut
+ nil
+ methodSpawn
+ classSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
"/ nil
"/ methodBreakPoint
"/ methodTrace
"/ methodTraceSender
- )
- receiver:self
- for:classMethodListView)
+ )
+ receiver:self
+ for:classMethodListView)
+!
+
+classMethodFileOutAll
+ "fileout all methods into one source file"
+
+ |list classString selectorString cls mth outStream fileName append
+ fileBox oldLabel|
+
+ append := false.
+ fileBox := FileSaveBox
+ title:(resources string:'save methodss in:')
+ okText:(resources string:'save')
+ abortText:(resources string:'cancel')
+ action:[:fName | fileName := fName].
+ fileBox appendAction:[:fName | fileName := fName. append := true].
+ fileBox initialText:'some_methods.st'.
+ Project notNil ifTrue:[
+ fileBox directory:Project currentProjectDirectory
+ ].
+ fileBox showAtPointer.
+
+ fileName notNil ifTrue:[
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ append ifTrue:[
+ outStream := FileStream appendingOldFileNamed:fileName
+ ] ifFalse:[
+ outStream := FileStream newFileNamed:fileName.
+ ].
+ outStream isNil ifTrue:[
+ ^ self warn:'cannot create: %1' with:fileName
+ ].
+ self withWaitCursorDo:[
+ list := classMethodListView list.
+ oldLabel := label.
+ list do:[:line |
+ self label:('System Browser writing: ' , line).
+
+ classString := self classFromClassMethodString:line.
+ selectorString := self selectorFromClassMethodString:line.
+
+ ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
+ classString := classString copyTo:(classString size - 5).
+ cls := (Smalltalk at:classString asSymbol).
+ cls := cls class
+ ] ifFalse:[
+ cls := (Smalltalk at:classString asSymbol).
+ ].
+
+ cls isNil ifTrue:[
+ self warn:'oops class %1 is gone' with:classString
+ ] ifFalse:[
+ mth := cls compiledMethodAt:(selectorString asSymbol).
+ Class fileOutErrorSignal handle:[:ex |
+ |box|
+ box := YesNoBox new.
+ box yesText:'continue' noText:'abort'.
+ (box confirm:('fileOut error: ' , ex errorString ,
+ '\\continue anyway ?') withCRs) ifTrue:[
+ ex proceed
+ ].
+ self label:'System Browser'.
+ ^ self
+ ] do:[
+ cls fileOutMethod:mth on:outStream.
+ ]
+ ]
+ ].
+ outStream close.
+ self label:oldLabel.
+ ]
+ ]
! !
!SystemBrowser methodsFor:'dependencies'!
@@ -4203,77 +4284,75 @@
oldClassCategory := currentClassCategory.
currentClass notNil ifTrue:[
- oldClassName := currentClass name
+ oldClassName := currentClass name
].
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
methodListView notNil ifTrue:[
- oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
- ]
+ oldMethod notNil ifTrue:[
+ oldSelector := methodListView selectionValue
+ ]
].
classCategoryListView notNil ifTrue:[
- classCategoryListView setContents:(self listOfAllClassCategories).
- oldClassCategory notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ].
- classCategoryListView selection isNil ifTrue:[
- currentClassCategory := nil.
- self switchToClass:nil.
- oldClassName := nil
- ]
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ].
+ classCategoryListView selection isNil ifTrue:[
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ oldClassName := nil
+ ]
].
classListView notNil ifTrue:[
- self updateClassListWithScroll:false.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName
- ].
- classListView selection isNil ifTrue:[
- self switchToClass:nil.
- currentMethodCategory := nil.
- oldMethodCategory := nil
- ]
+ self updateClassListWithScroll:false.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName
+ ].
+ classListView selection isNil ifTrue:[
+ self switchToClass:nil.
+ currentMethodCategory := nil.
+ oldMethodCategory := nil
+ ]
].
methodCategoryListView notNil ifTrue:[
- self updateMethodCategoryListWithScroll:false.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- methodCategoryListView selection isNil ifTrue:[
- currentMethodCategory := nil.
- currentMethod := nil.
- oldSelector := nil
- ]
+ self updateMethodCategoryListWithScroll:false.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ methodCategoryListView selection isNil ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ oldSelector := nil
+ ]
].
methodListView notNil ifTrue:[
- self updateMethodListWithScroll:false.
- oldSelector notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- methodListView selection isNil ifTrue:[
- currentMethod := nil
- ]
+ self updateMethodListWithScroll:false.
+ oldSelector notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ methodListView selection isNil ifTrue:[
+ currentMethod := nil
+ ]
].
self updateCodeView
!
-update:someObject
- (someObject == Smalltalk) ifTrue:[self update. ^ self].
- someObject isBehavior ifTrue:[
- currentClass notNil ifTrue:[
- someObject name = currentClass name ifTrue:[
- currentClass := someObject.
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- self updateMethodCategoryListWithScroll:false.
- "dont update codeView ...."
- "self update"
- ^ self
- ]
- ]
+update:something with:someArgument from:changedObject
+ (changedObject == Smalltalk) ifTrue:[self update. ^ self].
+ changedObject isBehavior ifTrue:[
+ (currentClass notNil and:[changedObject name = currentClass name]) ifTrue:[
+ currentClass := Smalltalk at:(currentClass name asSymbol).
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ "dont update codeView ...."
+ "self update"
+ ^ self
+ ]
]
! !
--- a/SystemBrowser.st Mon Oct 10 04:15:21 1994 +0100
+++ b/SystemBrowser.st Mon Oct 10 04:16:24 1994 +0100
@@ -2,7 +2,7 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -14,15 +14,14 @@
StandardSystemView subclass:#SystemBrowser
instanceVariableNames:'classCategoryListView classListView
- methodCategoryListView methodListView
- classMethodListView
- codeView classToggle instanceToggle
- currentClassCategory currentClassHierarchy
- currentClass
- currentMethodCategory currentMethod
- showInstance actualClass fullClass
- enterBox questBox
- selectBox lastMethodCategory'
+ methodCategoryListView methodListView
+ classMethodListView
+ codeView classToggle instanceToggle
+ currentClassCategory currentClassHierarchy
+ currentClass
+ currentMethodCategory currentMethod
+ showInstance actualClass fullClass
+ lastMethodCategory aspect'
classVariableNames:''
poolDictionaries:''
category:'Interface-Browsers'
@@ -30,9 +29,9 @@
SystemBrowser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
-
-$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.12 1994-08-23 23:49:31 claus Exp $
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.13 1994-10-10 03:16:03 claus Exp $
'!
!SystemBrowser class methodsFor:'documentation'!
@@ -40,7 +39,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -53,7 +52,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.12 1994-08-23 23:49:31 claus Exp $
+$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.13 1994-10-10 03:16:03 claus Exp $
"
!
@@ -83,8 +82,8 @@
Does not work currently - still being developped."
^ self newWithLabel:(self classResources string:'System Browser')
- setupBlock:[:browser | browser setupForAll]
- on:aDisplay
+ setupBlock:[:browser | browser setupForAll]
+ on:aDisplay
"
SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
@@ -97,7 +96,7 @@
"launch a browser showing all methods at once"
^ self newWithLabel:'Full Class Browser'
- setupBlock:[:browser | browser setupForFullClass]
+ setupBlock:[:browser | browser setupForFullClass]
"SystemBrowser browseFullClasses"
!
@@ -106,7 +105,7 @@
"launch a browser for all classes under aCategory"
^ self newWithLabel:aClassCategory
- setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
+ setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
"SystemBrowser browseClassCategory:'Kernel-Objects'"
!
@@ -115,7 +114,7 @@
"launch a browser for aClass"
^ self newWithLabel:aClass name
- setupBlock:[:browser | browser setupForClass:aClass]
+ setupBlock:[:browser | browser setupForClass:aClass]
"SystemBrowser browseClass:Object"
!
@@ -124,7 +123,7 @@
"launch a browser for aClass and all its superclasses"
^ self newWithLabel:(aClass name , '-' , 'hierarchy')
- setupBlock:[:browser | browser setupForClassHierarchy:aClass]
+ setupBlock:[:browser | browser setupForClassHierarchy:aClass]
"SystemBrowser browseClassHierarchy:Number"
!
@@ -133,12 +132,12 @@
"launch a browser for all classes in aList"
^ self newWithLabel:title
- setupBlock:[:browser | browser setupForClassList:aList]
+ setupBlock:[:browser | browser setupForClassList:aList]
"
SystemBrowser browseClasses:(Array with:Object
- with:Float)
- title:'two classes'
+ with:Float)
+ title:'two classes'
"
!
@@ -146,7 +145,7 @@
"launch a browser for all methods under aCategory in aClass"
^ self newWithLabel:(aClass name , ' ' , aCategory)
- setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
+ setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
"SystemBrowser browseClass:String methodCategory:'copying'"
!
@@ -155,7 +154,7 @@
"launch a browser for the method at selector in aClass"
^ self newWithLabel:(aClass name , ' ' , selector)
- setupBlock:[:browser | browser setupForClass:aClass selector:selector]
+ setupBlock:[:browser | browser setupForClass:aClass selector:selector]
"SystemBrowser browseClass:Object selector:#printString"
!
@@ -164,17 +163,17 @@
"launch a browser for an explicit list of class/selectors"
(aList size == 0) ifTrue:[
- self showNoneFound:aString.
- ^ nil
+ self showNoneFound:aString.
+ ^ nil
].
aList sort.
^ self newWithLabel:aString
- setupBlock:[:browser | browser setupForList:aList]
+ setupBlock:[:browser | browser setupForList:aList]
"
SystemBrowser browseMethods:#('Object printOn:'
- 'Collection add:')
- title:'some methods'
+ 'Collection add:')
+ title:'some methods'
"
!
@@ -184,9 +183,9 @@
|searchBlock|
aCategory includesMatchCharacters ifTrue:[
- searchBlock := [:c :m :s | aCategory match:m category].
+ searchBlock := [:c :m :s | aCategory match:m category].
] ifFalse:[
- searchBlock := [:c :m :s | m category = aCategory]
+ searchBlock := [:c :m :s | m category = aCategory]
].
self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
@@ -241,43 +240,43 @@
where aBlock evaluates to true.
The block is called with 3 arguments, class, method and seelctor."
- |list prio checkedClasses checkBlock|
+ |list|
"
since this may take a long time, lower my priority ...
"
- prio := Processor activeProcess priority.
- Processor activeProcess priority:(prio - 1).
-
- checkBlock := [:cls |
- |methodArray selectorArray|
-
- (checkedClasses includes:cls) ifFalse:[
- methodArray := cls methodArray.
- selectorArray := cls selectorArray.
-
- 1 to:methodArray size do:[:index |
- |method sel|
-
- method := methodArray at:index.
- sel := selectorArray at:index.
- (aBlock value:cls value:method value:sel) ifTrue:[
- list add:(cls name , ' ' , sel)
- ]
- ].
- checkedClasses add:cls.
- ]
- ].
-
- [
- checkedClasses := IdentitySet new.
- list := OrderedCollection new.
- aCollectionOfClasses do:[:aClass |
- wantInst ifTrue:[checkBlock value:aClass].
- wantClass ifTrue:[checkBlock value:(aClass class)]
- ]
- ] valueNowOrOnUnwindDo:[
- Processor activeProcess priority:prio.
+ Processor activeProcess withLowerPriorityDo:[
+ |checkedClasses checkBlock|
+
+ checkedClasses := IdentitySet new.
+ list := OrderedCollection new.
+
+ checkBlock := [:cls |
+ |methodArray selectorArray|
+
+ (checkedClasses includes:cls) ifFalse:[
+ methodArray := cls methodArray.
+ selectorArray := cls selectorArray.
+
+ 1 to:methodArray size do:[:index |
+ |method sel|
+
+ method := methodArray at:index.
+ sel := selectorArray at:index.
+ (aBlock value:cls value:method value:sel) ifTrue:[
+ list add:(cls name , ' ' , sel)
+ ]
+ ].
+ checkedClasses add:cls.
+ ]
+ ].
+
+ aCollectionOfClasses do:[:aClass |
+"/ Transcript show:'searching '; show:aClass name; showCr:' ...'; endEntry.
+ wantInst ifTrue:[checkBlock value:aClass].
+ wantClass ifTrue:[checkBlock value:(aClass class)].
+ Processor yield
+ ]
].
^ self browseMethods:list title:title
@@ -302,7 +301,7 @@
aCollectionOfClasses where aBlock evaluates to true"
^ self browseMethodsIn:aCollectionOfClasses inst:true class:false
- where:aBlock title:title
+ where:aBlock title:title
! !
!SystemBrowser class methodsFor:'special search startup'!
@@ -316,46 +315,46 @@
list := OrderedCollection new.
((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
- "a matchString"
-
- aCollectionOfClasses do:[:aClass |
- aClass selectorArray do:[:aSelector |
- (aSelectorString match:aSelector) ifTrue:[
- list add:(aClass name , ' ' , aSelector)
- ]
- ].
- aClass class selectorArray do:[:aSelector |
- (aSelectorString match:aSelector) ifTrue:[
- list add:(aClass name , 'class ' , aSelector)
- ]
- ]
- ]
+ "a matchString"
+
+ aCollectionOfClasses do:[:aClass |
+ aClass selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , ' ' , aSelector)
+ ]
+ ].
+ aClass class selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , 'class ' , aSelector)
+ ]
+ ]
+ ]
] ifFalse:[
- "can do a faster search"
-
- aSelectorString knownAsSymbol ifFalse:[
- self showNoneFound:title.
- ^ nil
- ].
-
- sel := aSelectorString asSymbol.
- aCollectionOfClasses do:[:aClass |
- (aClass implements:sel) ifTrue:[
- list add:(aClass name , ' ' , aSelectorString)
- ].
- (aClass class implements:sel) ifTrue:[
- list add:(aClass name , 'class ' , aSelectorString)
- ]
- ]
+ "can do a faster search"
+
+ aSelectorString knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ aCollectionOfClasses do:[:aClass |
+ (aClass implements:sel) ifTrue:[
+ list add:(aClass name , ' ' , aSelectorString)
+ ].
+ (aClass class implements:sel) ifTrue:[
+ list add:(aClass name , 'class ' , aSelectorString)
+ ]
+ ]
].
^ self browseMethods:list title:title
"
SystemBrowser browseImplementorsOf:#+
- in:(Array with:Number
- with:Float
- with:SmallInteger)
- title:'some implementors of +'
+ in:(Array with:Number
+ with:Float
+ with:SmallInteger)
+ title:'some implementors of +'
"
!
@@ -363,8 +362,8 @@
"launch a browser for all implementors of aSelector"
^ self browseImplementorsOf:aSelectorString
- in:(Smalltalk allClasses)
- title:('implementors of: ' , aSelectorString)
+ in:(Smalltalk allClasses)
+ title:('implementors of: ' , aSelectorString)
"
SystemBrowser browseImplementorsOf:#+
@@ -376,10 +375,10 @@
and its subclasses"
^ self browseImplementorsOf:aSelectorString
- in:(aClass withAllSubclasses)
- title:('implementors of: ' ,
- aSelectorString ,
- ' (in or below ' , aClass name , ')')
+ in:(aClass withAllSubclasses)
+ title:('implementors of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
"
SystemBrowser browseImplementorsOf:#+ under:Integer
@@ -392,42 +391,42 @@
|sel browser searchBlock|
((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (aSelectorString match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | searchBlock value:(method literals)]
- title:title
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSelectorString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | searchBlock value:(method literals)]
+ title:title
] ifFalse:[
- aSelectorString knownAsSymbol ifFalse:[
+ aSelectorString knownAsSymbol ifFalse:[
"
- Transcript showCr:'none found.'.
+ Transcript showCr:'none found.'.
"
- self showNoneFound:title.
- ^ nil
- ].
-
- sel := aSelectorString asSymbol.
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | method sends:sel]
- title:title
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | method sends:sel]
+ title:title
].
browser notNil ifTrue:[
- browser setSearchPattern:aSelectorString
+ browser setSearchPattern:aSelectorString
].
^ browser
!
@@ -436,8 +435,8 @@
"launch a browser for all senders of aSelector"
^ self browseAllCallsOn:aSelectorString
- in:(Smalltalk allClasses)
- title:('senders of ' , aSelectorString)
+ in:(Smalltalk allClasses)
+ title:('senders of ' , aSelectorString)
"
SystemBrowser browseAllCallsOn:#+
@@ -448,10 +447,10 @@
"launch a browser for all senders of aSelector in aClass and subclasses"
^ self browseAllCallsOn:aSelectorString
- in:(aClass withAllSubclasses)
- title:('senders of: ' ,
- aSelectorString ,
- ' (in or below ' , aClass name , ')')
+ in:(aClass withAllSubclasses)
+ title:('senders of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
"
SystemBrowser browseAllCallsOn:#+ under:Number
@@ -464,51 +463,51 @@
|browser searchBlock sym|
(aSymbol includesMatchCharacters) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (aSymbol match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSymbol match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
] ifFalse:[
- "
- can do a faster search
- "
- aSymbol knownAsSymbol ifFalse:[
- self showNoneFound:title.
- ^ nil
- ].
-
- sym := aSymbol asSymbol.
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (sym == aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
+ "
+ can do a faster search
+ "
+ aSymbol knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sym := aSymbol asSymbol.
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (sym == aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
].
browser := self browseMethodsWhere:[:c :m :s | searchBlock value:(m literals)] title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aSymbol
+ browser setSearchPattern:aSymbol
].
^ browser
!
@@ -540,52 +539,53 @@
!
browseForString:aString in:aCollectionOfClasses
- "launch a browser for all methods in aCollectionOfClasses containing a string"
+ "launch a browser for all methods in aCollectionOfClasses
+ containing a string-constant"
|browser searchBlock title|
title := 'methods containing: ' , aString displayString.
(aString includesMatchCharacters) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:String) ifTrue:[
- found := (aString match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
] ifFalse:[
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:String) ifTrue:[
- found := (aLiteral = aString)
- ]
- ]
- ]
- ].
- found
- ].
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aLiteral = aString)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
].
browser := self browseMethodsIn:aCollectionOfClasses
- where:[:c :m :s | searchBlock value:(m literals)]
- title:title.
+ where:[:c :m :s | searchBlock value:(m literals)]
+ title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aString
+ browser setSearchPattern:aString
].
^ browser
@@ -612,16 +612,17 @@
list := OrderedCollection new.
^ self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :sel |
- (matchString match:sel) ifTrue:[
- list add:(class name , '>>' , sel)
- ] ifFalse:[
- (matchString match:(method comment)) ifTrue:[
- list add:(class name , '>>' , sel)
- ]
- ]
- ]
- title:('apropos: ' , aString)
+ where:[:class :method :sel |
+ (matchString match:sel) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ] ifFalse:[
+ (matchString match:(method comment)) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ]
+ ].
+ Processor yield.
+ ]
+ title:('apropos: ' , aString)
"SystemBrowser aproposSearch:'append'"
"SystemBrowser aproposSearch:'add'"
@@ -646,44 +647,49 @@
needMatch := varName includesMatchCharacters.
searchBlock := [:c :m :s |
- |src result parser instvars|
-
- src := m source.
- needMatch ifFalse:[
- "
- before doing a slow parse, quickly scan the
- methods source for the variables name ...
- "
- result := (src findString:varName) ~~ 0.
- ] ifTrue:[
- result := true.
- ].
- result ifTrue:[
- result := false.
- parser := Parser parseMethod:src in:c.
- parser notNil ifTrue:[
- modsOnly ifTrue:[
- instvars := parser modifiedInstVars
- ] ifFalse:[
- instvars := parser usedInstVars
- ].
- instvars notNil ifTrue:[
- needMatch ifTrue:[
- instvars do:[:iv |
- (varName match:iv) ifTrue:[result := true]
- ]
- ] ifFalse:[
- result := instvars includes:varName
- ]
- ]
- ]
- ].
- result
+ |src result parser instvars|
+
+ src := m source.
+ src isNil ifTrue:[
+ result := false
+ ] ifFalse:[
+ needMatch ifFalse:[
+ "
+ before doing a slow parse, quickly scan the
+ methods source for the variables name ...
+ "
+ result := (src findString:varName) ~~ 0.
+ ] ifTrue:[
+ result := true.
+ ].
+ result ifTrue:[
+ result := false.
+ parser := Parser parseMethod:src in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ instvars := parser modifiedInstVars
+ ] ifFalse:[
+ instvars := parser usedInstVars
+ ].
+ instvars notNil ifTrue:[
+ needMatch ifTrue:[
+ instvars do:[:iv |
+ (varName match:iv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := instvars includes:varName
+ ]
+ ]
+ ]
+ ].
+ ].
+ Processor yield.
+ result
].
browser := self browseInstMethodsIn:aCollectionOfClasses where:searchBlock title:title.
browser notNil ifTrue:[
- browser setSearchPattern:varName
+ browser setSearchPattern:varName
].
^ browser
!
@@ -696,14 +702,14 @@
|title|
modsOnly ifTrue:[
- title := 'modifications of '
+ title := 'modifications of '
] ifFalse:[
- title := 'references to '
+ title := 'references to '
].
^ self browseInstRefsTo:aString
- in:aCollectionOfClasses
- modificationsOnly:modsOnly
- title:(title , aString)
+ in:aCollectionOfClasses
+ modificationsOnly:modsOnly
+ title:(title , aString)
!
browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
@@ -724,44 +730,49 @@
needMatch := varName includesMatchCharacters.
searchBlock := [:c :m :s |
- |src result parser classvars|
-
- src := m source.
- needMatch ifFalse:[
- "
- before doing a slow parse, quickly scan the
- methods source for the variables name ...
- "
- result := (src findString:varName) ~~ 0.
- ] ifTrue:[
- result := true.
- ].
- result ifTrue:[
- result := false.
- parser := Parser parseMethod:src in:c.
- parser notNil ifTrue:[
- modsOnly ifTrue:[
- classvars := parser modifiedClassVars
- ] ifFalse:[
- classvars := parser usedClassVars
- ].
- classvars notNil ifTrue:[
- needMatch ifTrue:[
- classvars do:[:cv |
- (varName match:cv) ifTrue:[result := true]
- ]
- ] ifFalse:[
- result := classvars includes:varName
- ]
- ]
- ].
- ].
- result
+ |src result parser classvars|
+
+ src := m source.
+ src isNil ifTrue:[
+ result := false
+ ] ifFalse:[
+ needMatch ifFalse:[
+ "
+ before doing a slow parse, quickly scan the
+ methods source for the variables name ...
+ "
+ result := (src findString:varName) ~~ 0.
+ ] ifTrue:[
+ result := true.
+ ].
+ result ifTrue:[
+ result := false.
+ parser := Parser parseMethod:src in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ classvars := parser modifiedClassVars
+ ] ifFalse:[
+ classvars := parser usedClassVars
+ ].
+ classvars notNil ifTrue:[
+ needMatch ifTrue:[
+ classvars do:[:cv |
+ (varName match:cv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := classvars includes:varName
+ ]
+ ]
+ ].
+ ].
+ ].
+ Processor yield.
+ result
].
browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
browser notNil ifTrue:[
- browser setSearchPattern:varName
+ browser setSearchPattern:varName
].
^ browser
!
@@ -774,9 +785,9 @@
|title|
modsOnly ifTrue:[
- title := 'modifications of '
+ title := 'modifications of '
] ifFalse:[
- title := 'references to '
+ title := 'references to '
].
^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
!
@@ -825,10 +836,11 @@
super initialize.
self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
- resolution:100).
+ resolution:100).
showInstance := true.
fullClass := false.
+ aspect := nil.
"inform me, when Smalltalk changes"
Smalltalk addDependent:self
@@ -839,53 +851,47 @@
Smalltalk removeDependent:self.
currentClass notNil ifTrue:[
- currentClass removeDependent:self.
- currentClass := nil
+ currentClass removeDependent:self.
+ currentClass := nil
].
- enterBox notNil ifTrue:[enterBox destroy. enterBox := nil].
- questBox notNil ifTrue:[questBox destroy. questBox := nil].
- selectBox notNil ifTrue:[selectBox destroy. selectBox := nil].
super destroy
!
terminate
(self checkSelectionChangeAllowed) ifTrue:[
- super terminate
+ super terminate
]
!
createTogglesIn:aFrame
"create and setup the class/instance toggles"
- |bw halfSpacing|
+ |halfSpacing h|
instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
- bw := instanceToggle borderWidth.
- halfSpacing := [
- (self is3D and:[style ~~ #st80]) ifTrue:[
- ViewSpacing // 2
- ] ifFalse:[
- 0
- ]
- ].
- instanceToggle extent:[(aFrame width // 2 - halfSpacing value) @ instanceToggle height].
- instanceToggle origin:[bw negated + halfSpacing value
- @
- (aFrame height - instanceToggle heightIncludingBorder + bw)].
+ h := instanceToggle height.
+ instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
+ instanceToggle topInset:(h negated).
instanceToggle turnOn.
instanceToggle pressAction:[self instanceProtocol].
instanceToggle releaseAction:[self classProtocol].
classToggle := Toggle label:(resources at:'class') in:aFrame.
- classToggle extent:[(aFrame width - (aFrame width // 2) - halfSpacing value) @ classToggle height].
- classToggle origin:[(aFrame width // 2 + halfSpacing value)
- @
- (aFrame height - classToggle heightIncludingBorder + bw)].
+ h := classToggle height.
+ classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
+ classToggle topInset:(h negated).
classToggle turnOff.
classToggle pressAction:[self classProtocol].
- classToggle releaseAction:[self instanceProtocol]
+ classToggle releaseAction:[self instanceProtocol].
+
+ StyleSheet is3D ifTrue:[
+ instanceToggle leftInset:(ViewSpacing // 2).
+ classToggle leftInset:(ViewSpacing // 2).
+ instanceToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+ classToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+ ].
!
createClassListViewIn:frame
@@ -898,10 +904,12 @@
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
- @
- (frame height
- - instanceToggle height
- - instanceToggle borderWidth)].
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
classListView := v scrolledView
!
@@ -956,12 +964,12 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
v := HVScrollableView for:SelectionInListView
- miniScrollerH:true miniScrollerV:false
- in:hpanel.
+ miniScrollerH:true miniScrollerV:false
+ in:hpanel.
v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
classCategoryListView := v scrolledView.
"/ classCategoryListView contents:(self listOfAllClassCategories).
@@ -987,8 +995,8 @@
|vpanel hpanel v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
@@ -1014,8 +1022,8 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
@@ -1046,7 +1054,7 @@
|vpanel hpanel frame l v|
vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
@@ -1078,8 +1086,8 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
@@ -1110,8 +1118,8 @@
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ corner:(1.0 @ 1.0)
+ in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
@@ -1121,8 +1129,12 @@
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
- @
- (frame height - instanceToggle heightIncludingBorder)].
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
@@ -1145,8 +1157,8 @@
|vpanel v|
vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
v := ScrollableView for:SelectionInListView in:vpanel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
@@ -1186,9 +1198,9 @@
|vpanel v|
vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
+ origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
v := ScrollableView for:SelectionInListView in:vpanel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
@@ -1210,43 +1222,43 @@
v := classCategoryListView.
v notNil ifTrue:[
- v action:[:lineNr | self classCategorySelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- v contents:(self listOfAllClassCategories).
- self initializeClassCategoryMenu
+ v action:[:lineNr | self classCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ v contents:(self listOfAllClassCategories).
+ self initializeClassCategoryMenu
].
v := classListView.
v notNil ifTrue:[
- v action:[:lineNr | self classSelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeClassMenu
+ v action:[:lineNr | self classSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMenu
].
v := methodCategoryListView.
v notNil ifTrue:[
- v action:[:lineNr | self methodCategorySelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeMethodCategoryMenu
+ v action:[:lineNr | self methodCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodCategoryMenu
].
v := methodListView.
v notNil ifTrue:[
- v action:[:lineNr | self methodSelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeMethodMenu
+ v action:[:lineNr | self methodSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodMenu
].
v := classMethodListView.
v notNil ifTrue:[
- v action:[:lineNr | self listSelection:lineNr].
- v selectConditionBlock:[self checkSelectionChangeAllowed].
- v ignoreReselect:false.
- self initializeClassMethodMenu
+ v action:[:lineNr | self listSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMethodMenu
]
! !
@@ -1260,27 +1272,22 @@
|box|
codeView modified ifFalse:[
- ^ true
- ].
- box := questBox.
- box isNil ifTrue:[
- box := questBox := YesNoBox title:''
+ ^ true
].
-
- box title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs.
- box okText:(resources at:'continue').
- box noText:(resources at:'abort').
- box yesAction:[^ true] noAction:[^ false].
- box showAtPointer
+ box := YesNoBox
+ title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs
+ yesText:(resources at:'continue')
+ noText:(resources at:'abort').
+ ^ box confirm
!
switchToClass:newClass
currentClass notNil ifTrue:[
- currentClass removeDependent:self
+ currentClass removeDependent:self
].
currentClass := newClass.
currentClass notNil ifTrue:[
- currentClass addDependent:self
+ currentClass addDependent:self
]
!
@@ -1301,28 +1308,28 @@
sel := codeView selection.
sel notNil ifTrue:[
- sel := sel asString.
- t := Parser selectorInExpression:sel.
- t notNil ifTrue:[
- sel := t
- ].
- sel := sel withoutSpaces
+ sel := sel asString.
+ t := Parser selectorInExpression:sel.
+ t notNil ifTrue:[
+ sel := t
+ ].
+ sel := sel withoutSpaces
] ifFalse:[
- methodListView notNil ifTrue:[
- sel := methodListView selectionValue
- ] ifFalse:[
- classMethodListView notNil ifTrue:[
- sel := classMethodListView selectionValue.
- sel notNil ifTrue:[
- sel := self selectorFromClassMethodString:sel
- ]
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
+ methodListView notNil ifTrue:[
+ sel := methodListView selectionValue
+ ] ifFalse:[
+ classMethodListView notNil ifTrue:[
+ sel := classMethodListView selectionValue.
+ sel notNil ifTrue:[
+ sel := self selectorFromClassMethodString:sel
+ ]
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
].
^ sel
!
@@ -1334,18 +1341,18 @@
sel := codeView selection.
sel notNil ifTrue:[
- sel := sel asString withoutSpaces
+ sel := sel asString withoutSpaces
] ifFalse:[
- sel isNil ifTrue:[
- currentClass notNil ifTrue:[
- sel := currentClass name
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
+ sel isNil ifTrue:[
+ currentClass notNil ifTrue:[
+ sel := currentClass name
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
].
^ sel
!
@@ -1362,39 +1369,34 @@
"
cls := currentClass.
[cls notNil] whileTrue:[
- ((cls perform:aSelector) includes:aVariableName) ifTrue:[
- homeClass := cls.
- cls := nil.
- ] ifFalse:[
- cls := cls superclass
- ]
+ ((cls perform:aSelector) includes:aVariableName) ifTrue:[
+ homeClass := cls.
+ cls := nil.
+ ] ifFalse:[
+ cls := cls superclass
+ ]
].
homeClass isNil ifTrue:[
- "nope, must be one below ... (could optimize a bit, by searching down
- for the declaring class ...
- "
- homeClass := currentClass
+ "nope, must be one below ... (could optimize a bit, by searching down
+ for the declaring class ...
+ "
+ homeClass := currentClass
] ifFalse:[
- Transcript showCr:'starting search in ' , homeClass name.
+ Transcript showCr:'starting search in ' , homeClass name.
].
^ homeClass
!
listBoxTitle:title okText:okText list:aList
- "convenient method: setup a listBox"
+ "convenient method: setup a listBox & return it"
|box|
- box := selectBox.
- box isNil ifTrue:[
- box := selectBox := ListSelectionBox
- title:''
- okText:(resources string:'ok')
- abortText:(resources string:'abort')
- action:[:aString | ]
- ].
+ box := ListSelectionBox new.
+ box okText:(resources string:okText).
box title:(resources string:title).
box list:aList.
+ ^ box
!
enterBoxTitle:title okText:okText
@@ -1402,83 +1404,88 @@
|box|
- box := enterBox.
- box isNil ifTrue:[
- box := enterBox := EnterBox new
- ].
+ box := EnterBox new.
box title:(resources string:title) okText:(resources string:okText).
- box initialText:''
+ ^ box
+!
+
+askBoxTitle:title okText:okText initialText:initialText action:aBlock
+ "convenient method: setup enterBox, and open it"
+
+ |box|
+
+ box := EnterBox new.
+ box title:(resources string:title) okText:(resources string:okText).
+ box initialText:initialText.
+ box action:[:aString | self withWaitCursorDo:aBlock value:aString].
+ box showAtPointer
!
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
- self enterBoxTitle:title okText:'search'.
- enterBox initialText:(self selectorToSearchFor)
+ |box|
+
+ box := self enterBoxTitle:title okText:'search'.
+ box initialText:(self selectorToSearchFor).
+ ^ box
!
-enterBoxForBrowseSelectorTitle:title
+askAndBrowseSelectorTitle:title action:aBlock
"convenient method: setup enterBox with text from codeView or selected
- method for browsing based on a selector"
-
- self enterBoxTitle:title okText:'browse'.
- enterBox initialText:(self selectorToSearchFor)
+ method for browsing based on a selector. Set action and launch box"
+
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self selectorToSearchFor).
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
!
-enterBoxForBrowseTitle:title
+enterBoxForBrowseTitle:title action:aBlock
"convenient method: setup enterBox with text from codeView or selected
method for method browsing based on className/variable"
- self enterBoxTitle:title okText:'browse'.
- enterBox initialText:(self stringToSearchFor)
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self stringToSearchFor).
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
!
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
- |sel|
-
- self enterBoxTitle:(resources string:title) okText:(resources string:okText).
+ |sel box|
+
+ box := self enterBoxTitle:(resources string:title) okText:(resources string:okText).
sel := codeView selection.
sel notNil ifTrue:[
- enterBox initialText:(sel asString withoutSeparators)
- ] ifFalse:[
- enterBox initialText:nil
- ]
+ box initialText:(sel asString withoutSeparators)
+ ].
+ ^ box
!
-enterBoxForMethodCategory:title
+askAndBrowseMethodCategory:title action:aBlock
"convenient method: setup enterBox with initial being current method category"
- |sel|
-
- self enterBoxTitle:title okText:'browse'.
+ |sel box|
+
+ box := self enterBoxTitle:title okText:'browse'.
sel := codeView selection.
sel isNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- sel := currentMethodCategory
- ]
+ currentMethodCategory notNil ifTrue:[
+ sel := currentMethodCategory
+ ]
].
sel notNil ifTrue:[
- enterBox initialText:(sel asString withoutSpaces)
- ]
-!
-
-newClassCategory:aString
- |categories|
-
- categories := classCategoryListView list.
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- self switchToClass:nil.
- actualClass := nil.
- self classCategorySelectionChanged
- ]
+ box initialText:(sel asString withoutSpaces)
+ ].
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
!
listOfAllClassCategories
@@ -1488,11 +1495,11 @@
newList := Text with:'* all *' with:'* hierarchy *'.
Smalltalk allBehaviorsDo:[:aClass |
- cat := aClass category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- newList indexOf:cat ifAbsent:[newList add:cat]
+ cat := aClass category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ newList indexOf:cat ifAbsent:[newList add:cat]
].
newList sort.
^ newList
@@ -1511,8 +1518,8 @@
theClass := aClass.
newList := Text with:theClass name.
[theClass ~~ Object] whileTrue:[
- theClass := theClass superclass.
- newList add:theClass name
+ theClass := theClass superclass.
+ newList add:theClass name
].
newList reverse.
^ newList
@@ -1526,36 +1533,36 @@
newList := Text new.
(aCategory = '* all *') ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
+ Smalltalk allBehaviorsDo:[:aClass |
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
] ifFalse:[
- (aCategory = '* hierarchy *') ifTrue:[
- classList := Text new.
- self classHierarchyDo:[:aClass :lvl|
- string := aClass name.
- classList indexOf:string ifAbsent:[
- classList add:string.
- newList add:(String new:lvl) , string
- ]
- ].
- ^ newList
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = searchCategory) ifTrue:[
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
- ]
- ]
- ]
+ (aCategory = '* hierarchy *') ifTrue:[
+ classList := Text new.
+ self classHierarchyDo:[:aClass :lvl|
+ string := aClass name.
+ classList indexOf:string ifAbsent:[
+ classList add:string.
+ newList add:(String new:lvl) , string
+ ]
+ ].
+ ^ newList
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = searchCategory) ifTrue:[
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
+ ]
+ ]
+ ]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
@@ -1570,15 +1577,15 @@
classes := Smalltalk allClasses.
classDict := IdentityDictionary new:classes size.
classes do:[:aClass |
- s := aClass superclass.
- s notNil ifTrue:[
- l := classDict at:s ifAbsent:[nil].
- l isNil ifTrue:[
- l := OrderedCollection new:5.
- classDict at:s put:l
- ].
- l add:aClass
- ]
+ s := aClass superclass.
+ s notNil ifTrue:[
+ l := classDict at:s ifAbsent:[nil].
+ l isNil ifTrue:[
+ l := OrderedCollection new:5.
+ classDict at:s put:l
+ ].
+ l add:aClass
+ ]
].
self classHierarchyOf:Object level:0 do:aBlock using:classDict
!
@@ -1592,11 +1599,11 @@
aBlock value:aClass value:level.
subclasses := aDictionary at:aClass ifAbsent:[nil].
(subclasses size == 0) ifFalse:[
- names := subclasses collect:[:class | class name].
- names sortWith:subclasses.
- subclasses do:[:aSubClass |
- self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
- ]
+ names := subclasses collect:[:class | class name].
+ names sortWith:subclasses.
+ subclasses do:[:aSubClass |
+ self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
+ ]
]
!
@@ -1607,11 +1614,11 @@
newList := Text new.
aClass methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
@@ -1625,27 +1632,27 @@
|newList searchCategory selector|
(aCategory = '* all *') ifTrue:[
- newList := aClass selectorArray asText
+ newList := aClass selectorArray asText
] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- newList := Text new.
- aClass methodArray do:[:aMethod |
- (aMethod category = searchCategory) ifTrue:[
- selector := aClass selectorForMethod:aMethod.
- selector notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- selector := selector , ' !!'
- ].
- (newList includes:selector) ifFalse:[
- newList add:selector
- ]
- ]
- ]
- ]
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ (aMethod category = searchCategory) ifTrue:[
+ selector := aClass selectorForMethod:aMethod.
+ selector notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ selector := selector , ' !!'
+ ].
+ (newList includes:selector) ifFalse:[
+ newList add:selector
+ ]
+ ]
+ ]
+ ]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
@@ -1659,21 +1666,21 @@
name := 'NewClass'.
i := 1.
[name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
- i := i + 1.
- name := 'NewClass' , i printString
+ i := i + 1.
+ name := 'NewClass' , i printString
].
aString := className , ' subclass:#' , name , '
- instanceVariableNames: ''''
- classVariableNames: ''''
- poolDictionaries: ''''
- category: '''.
-
- cat notNil ifTrue:[
- aString := aString , cat
- ].
- aString := aString , ''''.
- ^ aString
+ instanceVariableNames: ''''
+ classVariableNames: ''''
+ poolDictionaries: ''''
+ category: '''.
+
+ cat notNil ifTrue:[
+ aString := aString , cat
+ ].
+ aString := aString , ''''.
+ ^ aString
!
template
@@ -1697,35 +1704,35 @@
instanceProtocol
showInstance ifFalse:[
- self checkSelectionChangeAllowed ifTrue:[
- classToggle turnOff.
- instanceToggle turnOn.
- showInstance := true.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOff.
- classToggle turnOn
- ]
+ self checkSelectionChangeAllowed ifTrue:[
+ classToggle turnOff.
+ instanceToggle turnOn.
+ showInstance := true.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOff.
+ classToggle turnOn
+ ]
]
!
classProtocol
showInstance ifTrue:[
- self checkSelectionChangeAllowed ifTrue:[
- instanceToggle turnOff.
- classToggle turnOn.
- showInstance := false.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOn.
- classToggle turnOff
- ]
+ self checkSelectionChangeAllowed ifTrue:[
+ instanceToggle turnOff.
+ classToggle turnOn.
+ showInstance := false.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOn.
+ classToggle turnOff
+ ]
]
!
@@ -1740,39 +1747,39 @@
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
+ oldSelector := methodListView selectionValue
].
classCategoryListView notNil ifTrue:[
- newCategoryList := self listOfAllClassCategories.
- newCategoryList = classCategoryListView list ifFalse:[
- scroll ifTrue:[
- classCategoryListView contents:newCategoryList
- ] ifFalse:[
- classCategoryListView setContents:newCategoryList
- ]
- ]
+ newCategoryList := self listOfAllClassCategories.
+ newCategoryList = classCategoryListView list ifFalse:[
+ scroll ifTrue:[
+ classCategoryListView contents:newCategoryList
+ ] ifFalse:[
+ classCategoryListView setContents:newCategoryList
+ ]
+ ]
].
oldClassCategory notNil ifTrue:[
- classCategoryListView notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ]
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ]
].
classListView notNil ifTrue:[
- oldClass notNil ifTrue:[
- classListView selectElement:(oldClass name)
- ]
+ oldClass notNil ifTrue:[
+ classListView selectElement:(oldClass name)
+ ]
].
oldMethodCategory notNil ifTrue:[
- methodCategoryListView notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
+ methodCategoryListView notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
].
oldSelector notNil ifTrue:[
- methodListView notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
+ methodListView notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
]
!
@@ -1784,30 +1791,30 @@
|classes oldClassName|
classListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- currentClass := Smalltalk at:(oldClassName asSymbol).
- ].
-
- currentClassCategory notNil ifTrue:[
- classes := self listOfAllClassesInCategory:currentClassCategory
- ] ifFalse:[
- currentClassHierarchy notNil ifTrue:[
- classes := self listOfClassHierarchyOf:currentClassHierarchy
- ]
- ].
-
- classListView list = classes ifFalse:[
- scroll ifTrue:[
- classListView contents:classes
- ] ifFalse:[
- classListView setContents:classes
- ].
- oldClassName notNil ifTrue:[
- classListView setContents:classes.
- classListView selectElement:oldClassName
- ].
- ]
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ currentClass := Smalltalk at:(oldClassName asSymbol).
+ ].
+
+ currentClassCategory notNil ifTrue:[
+ classes := self listOfAllClassesInCategory:currentClassCategory
+ ] ifFalse:[
+ currentClassHierarchy notNil ifTrue:[
+ classes := self listOfClassHierarchyOf:currentClassHierarchy
+ ]
+ ].
+
+ classListView list = classes ifFalse:[
+ scroll ifTrue:[
+ classListView contents:classes
+ ] ifFalse:[
+ classListView setContents:classes
+ ].
+ oldClassName notNil ifTrue:[
+ classListView setContents:classes.
+ classListView selectElement:oldClassName
+ ].
+ ]
]
!
@@ -1819,19 +1826,19 @@
|categories|
methodCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInClass:actualClass
- ].
- methodCategoryListView list = categories ifFalse:[
- scroll ifTrue:[
- methodCategoryListView contents:categories
- ] ifFalse:[
- methodCategoryListView setContents:categories
- ].
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
+ currentClass notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInClass:actualClass
+ ].
+ methodCategoryListView list = categories ifFalse:[
+ scroll ifTrue:[
+ methodCategoryListView contents:categories
+ ] ifFalse:[
+ methodCategoryListView setContents:categories
+ ].
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
]
!
@@ -1843,25 +1850,25 @@
|selectors scr first last|
methodListView notNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- ofClass:actualClass
- ].
- scr := scroll.
- first := methodListView firstLineShown.
- first ~~ 1 ifTrue:[
- last := methodListView lastLineShown.
- selectors size <= (last - first + 1) ifTrue:[
- scr := true
- ]
- ].
- methodListView list = selectors ifFalse:[
- scr ifTrue:[
- methodListView contents:selectors
- ] ifFalse:[
- methodListView setContents:selectors
- ]
- ].
+ currentMethodCategory notNil ifTrue:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ ofClass:actualClass
+ ].
+ scr := scroll.
+ first := methodListView firstLineShown.
+ first ~~ 1 ifTrue:[
+ last := methodListView lastLineShown.
+ selectors size <= (last - first + 1) ifTrue:[
+ scr := true
+ ]
+ ].
+ methodListView list = selectors ifFalse:[
+ scr ifTrue:[
+ methodListView contents:selectors
+ ] ifFalse:[
+ methodListView setContents:selectors
+ ]
+ ].
]
!
@@ -1873,36 +1880,36 @@
|code aStream|
fullClass ifTrue:[
- currentClass notNil ifTrue:[
+ currentClass notNil ifTrue:[
" this is too slow for big classes ...
- code := String new:1000.
- aStream := WriteStream on:code.
- currentClass fileOutOn:aStream
+ code := String new:1000.
+ aStream := WriteStream on:code.
+ currentClass fileOutOn:aStream
"
- aStream := FileStream newFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'cannot create temporary file.'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- currentClass fileOutOn:aStream.
- aStream close.
- aStream := FileStream oldFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'oops - cannot reopen temp file'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- code := aStream contents.
- aStream close.
- OperatingSystem removeFile:'__temp'
- ]
+ aStream := FileStream newFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'cannot create temporary file.'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ currentClass fileOutOn:aStream.
+ aStream close.
+ aStream := FileStream oldFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'oops - cannot reopen temp file'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ code := aStream contents.
+ aStream close.
+ OperatingSystem removeFile:'__temp'
+ ]
] ifFalse:[
- currentMethod notNil ifTrue:[
- code := currentMethod source
- ]
+ currentMethod notNil ifTrue:[
+ code := currentMethod source
+ ]
].
codeView contents:code.
codeView modified:false
@@ -1912,80 +1919,80 @@
|oldMethodCategory oldMethod|
self withWaitCursorDo:[
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
-
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
-
- self updateMethodCategoryList.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- methodCategoryListView selection notNil ifTrue:[
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ].
- self updateMethodList.
- self updateCodeView.
-
- fullClass ifTrue:[
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- self compileCode:theCode asString.
- codeView modified:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ] ifFalse:[
- self classDefinition.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- codeView modified:false.
- ].
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ].
- classCategoryListView notNil ifTrue:[
- (currentClassCategory = currentClass category) ifFalse:[
- currentClassCategory := currentClass category.
- classCategoryListView selectElement:currentClassCategory
- ]
- ].
-
- "set self for doits. This allows accessing the current class
- as self, and access to the class variables by name."
-
- codeView doItAction:[:theCode |
- |compiler|
-
- currentClass isNil ifTrue:[
- compiler := Compiler
- ] ifFalse:[
- compiler := currentClass compiler
- ].
- compiler
- evaluate:theCode
- in:nil
- receiver:currentClass
- notifying:codeView
- logged:false
- ifFail:nil
- ]
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateMethodCategoryList.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ methodCategoryListView selection notNil ifTrue:[
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ].
+ self updateMethodList.
+ self updateCodeView.
+
+ fullClass ifTrue:[
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ self compileCode:theCode asString.
+ codeView modified:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ] ifFalse:[
+ self classDefinition.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ codeView modified:false.
+ ].
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ].
+ classCategoryListView notNil ifTrue:[
+ (currentClassCategory = currentClass category) ifFalse:[
+ currentClassCategory := currentClass category.
+ classCategoryListView selectElement:currentClassCategory
+ ]
+ ].
+
+ "set self for doits. This allows accessing the current class
+ as self, and access to the class variables by name."
+
+ codeView doItAction:[:theCode |
+ |compiler|
+
+ currentClass isNil ifTrue:[
+ compiler := Compiler
+ ] ifFalse:[
+ compiler := currentClass compiler
+ ].
+ compiler
+ evaluate:theCode
+ in:nil
+ receiver:currentClass
+ notifying:codeView
+ logged:false
+ ifFail:nil
+ ]
]
!
@@ -1993,18 +2000,18 @@
"class category has changed - update dependant views"
self withWaitCursorDo:[
- self switchToClass:nil.
- actualClass := nil.
- currentMethodCategory := nil.
- currentMethod := nil.
-
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
-
- codeView explainAction:nil.
- codeView acceptAction:nil
+ self switchToClass:nil.
+ actualClass := nil.
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+
+ codeView explainAction:nil.
+ codeView acceptAction:nil
]
!
@@ -2016,29 +2023,29 @@
newCategory := classCategoryListView selectionValue.
(newCategory startsWith:'*') ifTrue:[
- "etiher all or hierarchy;
- remember current selections and switch after showing class list"
- oldClass := currentClass
+ "etiher all or hierarchy;
+ remember current selections and switch after showing class list"
+ oldClass := currentClass
].
currentClassCategory := newCategory.
oldClass isNil ifTrue:[
- self classCategorySelectionChanged
+ self classCategorySelectionChanged
] ifFalse:[
- self withWaitCursorDo:[
- self updateClassList
- ].
- "stupid - search for class name in (indented) list"
- index := 1.
- classListView list do:[:elem |
- (elem endsWith:(oldClass name)) ifTrue:[
- classIndex := index
- ].
- index := index + 1
- ].
- classIndex notNil ifTrue:[
- classListView selection:classIndex.
- self switchToClass:(Smalltalk at:(oldClass name asSymbol))
- ]
+ self withWaitCursorDo:[
+ self updateClassList
+ ].
+ "stupid - search for class name in (indented) list"
+ index := 1.
+ classListView list do:[:elem |
+ (elem endsWith:(oldClass name)) ifTrue:[
+ classIndex := index
+ ].
+ index := index + 1
+ ].
+ classIndex notNil ifTrue:[
+ classListView selection:classIndex.
+ self switchToClass:(Smalltalk at:(oldClass name asSymbol))
+ ]
]
!
@@ -2049,11 +2056,11 @@
classSymbol := classListView selectionValue withoutSpaces asSymbol.
(Smalltalk includesKey:classSymbol) ifTrue:[
- cls := Smalltalk at:classSymbol
+ cls := Smalltalk at:classSymbol
].
cls notNil ifTrue:[
- self switchToClass:cls.
- self classSelectionChanged
+ self switchToClass:cls.
+ self classSelectionChanged
]
!
@@ -2061,32 +2068,32 @@
"method category selection has changed - update dependant views"
self withWaitCursorDo:[
- currentMethod := nil.
-
- self updateMethodList.
- self updateCodeView.
-
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ].
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ]
+ currentMethod := nil.
+
+ self updateMethodList.
+ self updateCodeView.
+
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ].
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ]
]
!
@@ -2103,31 +2110,31 @@
"method selection has changed - update dependant views"
self withWaitCursorDo:[
- self updateCodeView.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ].
- methodListView notNil ifTrue:[
- (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
- self initializeMethodMenu2
- ] ifFalse:[
- self initializeMethodMenu
- ]
- ]
+ self updateCodeView.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ].
+ methodListView notNil ifTrue:[
+ (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
+ self initializeMethodMenu2
+ ] ifFalse:[
+ self initializeMethodMenu
+ ]
+ ]
]
!
@@ -2143,18 +2150,18 @@
kludge: check if its a wrapped one
"
(selectorString endsWith:' !!') ifTrue:[
- selectorString := selectorString copyTo:(selectorString size - 2)
+ selectorString := selectorString copyTo:(selectorString size - 2)
].
selectorSymbol := selectorString asSymbol.
currentMethod := actualClass compiledMethodAt:selectorSymbol.
methodCategoryListView notNil ifTrue:[
- currentMethod notNil ifTrue:[
- (currentMethodCategory = currentMethod category) ifFalse:[
- currentMethodCategory := currentMethod category.
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
+ currentMethod notNil ifTrue:[
+ (currentMethodCategory = currentMethod category) ifFalse:[
+ currentMethodCategory := currentMethod category.
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
].
self methodSelectionChanged
@@ -2187,21 +2194,21 @@
classString := self classFromClassMethodString:string.
selectorString := self selectorFromClassMethodString:string.
((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass class
+ classString := classString copyTo:(classString size - 5).
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass class
] ifFalse:[
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass
].
currentClass isNil ifTrue:[
- self warn:'oops class is gone'
+ self warn:'oops class is gone'
] ifFalse:[
- currentClassCategory := currentClass category.
- currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
- currentMethodCategory := currentMethod category.
-
- self methodSelectionChanged
+ currentClassCategory := currentClass category.
+ currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
+ currentMethodCategory := currentMethod category.
+
+ self methodSelectionChanged
]
! !
@@ -2211,46 +2218,43 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'fileOut each'
+ 'fileOut'
+ 'fileOut each'
"
- 'fileOut binary'
+ 'fileOut binary'
"
- 'printOut'
- 'printOut protocol'
- '-'
- 'spawn'
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- 'rename ...'
- 'remove').
+ 'printOut'
+ 'printOut protocol'
+ '-'
+ 'SPAWN_CATEGORY'
+ 'spawn full class'
+ '-'
+ 'update'
+ 'find class ...'
+ '-'
+ 'new class category ...'
+ 'rename ...'
+ 'remove').
classCategoryListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(classCategoryFileOut
- classCategoryFileOutEach
-"
- classCategoryBinaryFileOut
-"
- classCategoryPrintOut
- classCategoryPrintOutProtocol
- nil
- classCategorySpawn
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- classCategoryRename
- classCategoryRemove)
- receiver:self
- for:classCategoryListView)
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(classCategoryFileOut
+ classCategoryFileOutEach
+ classCategoryPrintOut
+ classCategoryPrintOutProtocol
+ nil
+ classCategorySpawn
+ classCategorySpawnFullClass
+ nil
+ classCategoryUpdate
+ classCategoryFindClass
+ nil
+ classCategoryNewCategory
+ classCategoryRename
+ classCategoryRemove)
+ receiver:self
+ for:classCategoryListView)
!
allClassesInCurrentCategoryInOrderDo:aBlock
@@ -2260,16 +2264,16 @@
|classes|
currentClassCategory notNil ifTrue:[
- classes := OrderedCollection new.
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- classes add:aClass
- ]
- ]
- ].
- classes topologicalSort:[:a :b | b isSubclassOf:a].
- classes do:aBlock
+ classes := OrderedCollection new.
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ classes add:aClass
+ ]
+ ]
+ ].
+ classes topologicalSort:[:a :b | b isSubclassOf:a].
+ classes do:aBlock
]
!
@@ -2278,13 +2282,13 @@
superclasses come first - then subclasses"
currentClassCategory notNil ifTrue:[
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- aBlock value:aClass
- ]
- ]
- ].
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+ ].
]
!
@@ -2294,29 +2298,29 @@
|oldClassName oldMethodCategory|
classCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- (oldClassName endsWith:'-old') ifTrue:[
- oldClassName := oldClassName copyTo:(oldClassName size - 4)
- ]
- ].
- oldMethodCategory := currentMethodCategory.
-
- classCategoryListView setContents:(self listOfAllClassCategories).
- currentClassCategory notNil ifTrue:[
- classCategoryListView selectElement:currentClassCategory.
- self classCategorySelectionChanged.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName.
- self switchToClass:(Smalltalk at:oldClassName asSymbol).
- self classSelectionChanged.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ]
- ]
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ (oldClassName endsWith:'-old') ifTrue:[
+ oldClassName := oldClassName copyTo:(oldClassName size - 4)
+ ]
+ ].
+ oldMethodCategory := currentMethodCategory.
+
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ currentClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:currentClassCategory.
+ self classCategorySelectionChanged.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName.
+ self switchToClass:(Smalltalk at:oldClassName asSymbol).
+ self classSelectionChanged.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ]
+ ]
]
!
@@ -2324,9 +2328,9 @@
|printStream|
self allClassesInCurrentCategoryInOrderDo:[:aClass |
- printStream := Printer new.
- aClass printOutProtocolOn:printStream.
- printStream close
+ printStream := Printer new.
+ aClass printOutProtocolOn:printStream.
+ printStream close
]
!
@@ -2334,20 +2338,18 @@
|printStream|
self allClassesInCurrentCategoryDo:[:aClass |
- printStream := Printer new.
- aClass printOutOn:printStream.
- printStream close
+ printStream := Printer new.
+ aClass printOutOn:printStream.
+ printStream close
]
!
classCategoryFileOut
"create a file 'categoryName' consisting of all classes in current category"
- |aStream fileName project|
-
- currentClassCategory isNil ifTrue:[
- ^ self warn:'select a class category first'.
- ].
+ |aStream fileName|
+
+ self checkClassCategorySelected ifFalse:[^ self].
fileName := currentClassCategory asString.
fileName replaceAll:Character space by:$_.
@@ -2355,38 +2357,41 @@
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
+ fileName := Project currentProjectDirectory , fileName.
].
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
- ^ self warn:(resources string:'cannot create: %1' with:fileName)
+ ^ self warn:'cannot create: %1' with:fileName
].
self withWaitCursorDo:[
- self label:('System Browser writing: ' , fileName).
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass fileOutOn:aStream.
- ].
- aStream close.
- self label:'System Browser'.
+ self label:('System Browser writing: ' , fileName).
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass fileOutOn:aStream.
+ ].
+ aStream close.
+ self label:'System Browser'.
]
!
classCategoryFileOutEach
self withWaitCursorDo:[
- self allClassesInCurrentCategoryDo:[:aClass |
- self label:('System Browser saving: ' , aClass name).
- aClass fileOut
- ].
- self label:'System Browser'.
- ]
-!
-
-classCategoryBinaryFileOut
- self withWaitCursorDo:[
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass binaryFileOut
- ]
+ self allClassesInCurrentCategoryDo:[:aClass |
+ self label:('System Browser saving: ' , aClass name).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ aClass fileOut
+ ]
+ ].
+ self label:'System Browser'.
]
!
@@ -2394,9 +2399,9 @@
"create a new SystemBrowser browsing current classCategory"
currentClassCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClassCategory:currentClassCategory
- ]
+ self withWaitCursorDo:[
+ self class browseClassCategory:currentClassCategory
+ ]
]
!
@@ -2406,20 +2411,36 @@
|newBrowser|
self withWaitCursorDo:[
- newBrowser := self class browseFullClasses
+ newBrowser := self class browseFullClasses
"
- .
- currentClass notNil ifTrue:[
- newBrowser switchToClassNamed:(currentClass name)
- ]
+ .
+ currentClass notNil ifTrue:[
+ newBrowser switchToClassNamed:(currentClass name)
+ ]
"
]
!
classCategoryNewCategory
- self enterBoxTitle:'name of new class category:' okText:'create'.
- enterBox action:[:aString | self newClassCategory:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxTitle:'name of new class category:' okText:'create'.
+ box action:[:aString |
+ |categories|
+
+ categories := classCategoryListView list.
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ self switchToClass:nil.
+ actualClass := nil.
+ self classCategorySelectionChanged
+ ]
+ ].
+ box showAtPointer
!
switchToClassNamed:aString
@@ -2428,50 +2449,53 @@
classSymbol := aString asSymbol.
theClass := Smalltalk at:classSymbol.
theClass isBehavior ifTrue:[
- classCategoryListView notNil ifTrue:[
- currentClassHierarchy isNil ifTrue:[
- (theClass category ~~ currentClassCategory) ifTrue:[
- currentClassCategory := theClass category.
- currentClassCategory isNil ifTrue:[
- classCategoryListView selectElement:'* no category *'
- ] ifFalse:[
- classCategoryListView selectElement:currentClassCategory
- ].
- self classCategorySelectionChanged
- ]
- ]
- ].
- self switchToClass:theClass.
- classListView selectElement:aString.
- self classSelectionChanged
+ classCategoryListView notNil ifTrue:[
+ currentClassHierarchy isNil ifTrue:[
+ (theClass category ~~ currentClassCategory) ifTrue:[
+ currentClassCategory := theClass category.
+ currentClassCategory isNil ifTrue:[
+ classCategoryListView selectElement:'* no category *'
+ ] ifFalse:[
+ classCategoryListView selectElement:currentClassCategory
+ ].
+ self classCategorySelectionChanged
+ ]
+ ]
+ ].
+ self switchToClass:theClass.
+ classListView selectElement:aString.
+ self classSelectionChanged
]
!
switchToClassNameMatching:aMatchString
- |classNames thisName|
+ |classNames thisName box|
classNames := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
- thisName := aClass name.
- (aMatchString match:thisName) ifTrue:[
- classNames add:thisName
- ]
+ thisName := aClass name.
+ (aMatchString match:thisName) ifTrue:[
+ classNames add:thisName
+ ]
].
(classNames size == 0) ifTrue:[^ nil].
(classNames size == 1) ifTrue:[
- ^ self switchToClassNamed:(classNames at:1)
+ ^ self switchToClassNamed:(classNames at:1)
].
- self listBoxTitle:'select class to switch to:'
- okText:'ok'
- list:classNames sort.
- selectBox action:[:aString | self switchToClassNamed:aString].
- selectBox showAtPointer
+
+ box := self listBoxTitle:'select class to switch to:'
+ okText:'ok'
+ list:classNames sort.
+ box action:[:aString | self switchToClassNamed:aString].
+ box showAtPointer
!
classCategoryFindClass
- self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
- enterBox action:[:aString | self switchToClassNameMatching:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
+ box action:[:aString | self switchToClassNameMatching:aString].
+ box showAtPointer
!
renameCurrentClassCategoryTo:aString
@@ -2480,65 +2504,64 @@
|any categories|
currentClassCategory notNil ifTrue:[
- any := false.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- aClass category:aString.
- any := true
- ]
- ].
- any ifFalse:[
- categories := classCategoryListView list.
- categories remove:currentClassCategory.
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- ] ifTrue:[
- currentClassCategory := aString.
- self updateClassCategoryList.
- self updateClassListWithScroll:false
- ]
+ any := false.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ aClass category:aString.
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ categories := classCategoryListView list.
+ categories remove:currentClassCategory.
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ ] ifTrue:[
+ currentClassCategory := aString.
+ self updateClassCategoryList.
+ self updateClassListWithScroll:false
+ ]
]
!
classCategoryRename
"launch an enterBox to rename current class category"
- currentClassCategory isNil ifTrue:[
- ^ self warn:'select a class category first'.
- ].
- self enterBoxTitle:'rename class category to:' okText:'rename'.
- enterBox initialText:currentClassCategory.
- enterBox action:[:aString | self renameCurrentClassCategoryTo:aString].
- enterBox showAtPointer
+ |box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:'rename class category to:' okText:'rename'.
+ box initialText:currentClassCategory.
+ box action:[:aString | self renameCurrentClassCategoryTo:aString].
+ box showAtPointer
!
classCategoryRemove
"remove all classes in current category"
- |count t classesToRemove subclassesRemoved|
-
- currentClassCategory isNil ifTrue:[
- ^ self warn:'select a class category first'.
- ].
+ |count t classesToRemove subclassesRemoved box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
classesToRemove := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- classesToRemove add:aClass
- ]
+ aClass category = currentClassCategory ifTrue:[
+ classesToRemove add:aClass
+ ]
].
subclassesRemoved := OrderedCollection new.
classesToRemove do:[:aClass |
- aClass allSubclassesDo:[:aSubclass |
- (classesToRemove includes:aSubclass) ifFalse:[
- (subclassesRemoved includes:aSubclass) ifFalse:[
- subclassesRemoved add:aSubclass
- ]
- ]
- ]
+ aClass allSubclassesDo:[:aSubclass |
+ (classesToRemove includes:aSubclass) ifFalse:[
+ (subclassesRemoved includes:aSubclass) ifFalse:[
+ subclassesRemoved add:aSubclass
+ ]
+ ]
+ ]
].
count := classesToRemove size.
@@ -2546,9 +2569,9 @@
count ~~ 0 ifTrue:[
t := t , (resources at:'\(with ') , count printString.
count == 1 ifTrue:[
- t := t , (resources at:' class')
+ t := t , (resources at:' class')
] ifFalse:[
- t := t , (resources at:' classes')
+ t := t , (resources at:' classes')
].
t := (t , ')') withCRs
].
@@ -2557,35 +2580,32 @@
count ~~ 0 ifTrue:[
t := t , (resources at:'\(and ') , count printString.
count == 1 ifTrue:[
- t := t , (resources at:' subclass ')
+ t := t , (resources at:' subclass ')
] ifFalse:[
- t := t , (resources at:' subclasses ')
+ t := t , (resources at:' subclasses ')
].
t := (t , ')') withCRs
].
t := t withCRs.
- questBox isNil ifTrue:[questBox := YesNoBox title:''].
- questBox title:t.
- questBox yesAction:[self doRemoveClasses:classesToRemove and:subclassesRemoved].
- questBox okText:(resources at:'remove').
- questBox noText:(resources at:'abort').
- questBox showAtPointer
-!
-
-doRemoveClasses:classList and:subclassList
- "after querying user - do really remove classes in list1 and list2"
-
- subclassList do:[:aClass |
- Smalltalk removeClass:aClass
- ].
- classList do:[:aClass |
- Smalltalk removeClass:aClass
- ].
- currentClassCategory := nil.
- self switchToClass:nil.
- Smalltalk changed
+ box := YesNoBox
+ title:t
+ yesText:(resources at:'remove')
+ noText:(resources at:'abort').
+ box confirm ifTrue:[
+ "after querying user - do really remove classes in list1 and list2"
+
+ subclassesRemoved do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ classesToRemove do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ Smalltalk changed
+ ]
! !
!SystemBrowser methodsFor:'class menu'!
@@ -2594,109 +2614,131 @@
|labels menu|
labels := resources array:#(
- 'fileOut'
-"
- 'fileOut binary'
-"
- 'printOut'
- 'printOut protocol'
- " 'printOut full protocol' "
- '-'
- 'spawn'
- 'spawn hierarchy'
- 'spawn subclasses'
- '-'
- 'hierarchy'
- 'definition'
- 'comment'
- 'class instvars'
- " 'protocols' "
- '-'
- 'variable search'
- '-'
- 'new class'
- 'new subclass'
- 'rename ...'
- 'remove').
+ 'fileOut'
+ 'printOut'
+ 'printOut protocol'
+ " 'printOut full protocol' "
+ '-'
+ 'SPAWN_CLASS'
+ 'spawn hierarchy'
+ 'spawn subclasses'
+ '-'
+ 'hierarchy'
+ 'definition'
+ 'comment'
+ 'class instvars'
+ " 'protocols' "
+ '-'
+ 'variable search'
+ 'class refs'
+ '-'
+ 'new class'
+ 'new subclass'
+ 'rename ...'
+ 'remove').
menu := PopUpMenu labels:labels
- selectors:#(classFileOut
-"
- classBinaryFileOut
-"
- classPrintOut
- classPrintOutProtocol
- " classPrintOutFullProtocol "
- nil
- classSpawn
- classSpawnHierarchy
- classSpawnSubclasses
- nil
- classHierarchy
- classDefinition
- classComment
- classClassInstVars
- " classProtocols "
- nil
-"
- classInstVarRefs
- classClassVarRefs
- classAllInstVarRefs
- classAllClassVarRefs
- nil
- classInstVarMods
- classClassVarMods
- classAllInstVarMods
- classAllClassVarMods
-"
- variables
- nil
- classNewClass
- classNewSubclass
- classRename
- classRemove)
- receiver:self
- for:classListView.
+ selectors:#(classFileOut
+ classPrintOut
+ classPrintOutProtocol
+ " classPrintOutFullProtocol "
+ nil
+ classSpawn
+ classSpawnHierarchy
+ classSpawnSubclasses
+ nil
+ classHierarchy
+ classDefinition
+ classComment
+ classClassInstVars
+ " classProtocols "
+ nil
+ variables
+ classRefs
+ nil
+ classNewClass
+ classNewSubclass
+ classRename
+ classRemove)
+ receiver:self
+ for:classListView.
classListView middleButtonMenu:menu.
menu subMenuAt:#variables
- put:(PopUpMenu labels:(resources array:#(
- 'instvar refs ...'
- 'classvar refs ...'
- 'all instvar refs ...'
- 'all classvar refs ...'
- '-'
- 'instvar mods ...'
- 'classvar mods ...'
- 'all instvar mods ...'
- 'all classvar mods ...'
- ))
- selectors:#(
- classInstVarRefs
- classClassVarRefs
- classAllInstVarRefs
- classAllClassVarRefs
- nil
- classInstVarMods
- classClassVarMods
- classAllInstVarMods
- classAllClassVarMods
- )
- receiver:self
- for:self
-
- ).
+ put:(PopUpMenu labels:(resources array:#(
+ 'instvar refs ...'
+ 'classvar refs ...'
+ 'all instvar refs ...'
+ 'all classvar refs ...'
+ '-'
+ 'instvar mods ...'
+ 'classvar mods ...'
+ 'all instvar mods ...'
+ 'all classvar mods ...'
+ ))
+ selectors:#(
+ classInstVarRefs
+ classClassVarRefs
+ classAllInstVarRefs
+ classAllClassVarRefs
+ nil
+ classInstVarMods
+ classClassVarMods
+ classAllInstVarMods
+ classAllClassVarMods
+ )
+ receiver:self
+ for:self
+
+ ).
+!
+
+checkClassCategorySelected
+ currentClassCategory isNil ifTrue:[
+ self warn:'select a class category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+checkClassSelected
+ currentClass isNil ifTrue:[
+ self warn:'select a class first'.
+ ^ false
+ ].
+ ^ true
+!
+
+checkMethodCategorySelected
+ currentMethodCategory isNil ifTrue:[
+ self warn:'select a method category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+whenMethodCategorySelected:aBlock
+ self checkMethodCategorySelected ifTrue:[
+ self withWaitCursorDo:aBlock
+ ]
+!
+
+checkMethodSelected
+ currentMethod isNil ifTrue:[
+ self warn:'select a method first'.
+ ^ false
+ ].
+ ^ true
!
doClassMenu:aBlock
"a helper - check if class is selected and evaluate aBlock
while showing waitCursor"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self withWaitCursorDo:aBlock
+ self checkClassSelected ifTrue:[
+ self withWaitCursorDo:aBlock
+ ]
!
doClassMenuWithSelection:aBlock
@@ -2709,39 +2751,27 @@
clsName := codeView selection.
clsName notNil ifTrue:[
- clsName := clsName asString withoutSeparators.
- (clsName endsWith:'class') ifTrue:[
- isMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- isMeta := false
- ].
- clsName knownAsSymbol ifTrue:[
- (Smalltalk includesKey:clsName asSymbol) ifTrue:[
- cls := Smalltalk at:clsName asSymbol.
- cls isBehavior ifTrue:[
- isMeta ifTrue:[
- cls := cls class
- ].
- self withWaitCursorDo:[
- aBlock value:cls.
- ].
- ^ self
- ] ifFalse:[
- w := clsName , ' is not a class'
- ]
- ] ifFalse:[
- w := clsName , ' is unknown'
- ].
- self warn:w.
- ^ self
- ].
+ clsName := clsName asString withoutSeparators.
+ (clsName endsWith:'class') ifTrue:[
+ isMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ isMeta := false
+ ].
+ (cls := Smalltalk classNamed:clsName) notNil ifTrue:[
+ isMeta ifTrue:[
+ cls := cls class
+ ].
+ self withWaitCursorDo:[
+ aBlock value:cls.
+ ].
+ ] ifFalse:[
+ self warn:'no class named: %1' with:clsName
+ ].
+ ^ self
].
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self withWaitCursorDo:[aBlock value:currentClass]
+ self doClassMenu:[aBlock value:currentClass]
!
classSpawn
@@ -2751,18 +2781,18 @@
|browser|
self doClassMenuWithSelection:[:cls |
- cls isMeta ifTrue:[
- Smalltalk allClassesDo:[:aClass |
- aClass class == cls ifTrue:[
- browser := self class browseClass:aClass.
- browser classProtocol.
- ^ self
- ].
- ].
- self warn:'oops, no class for this metaclass'.
- ^ self
- ].
- self class browseClass:cls
+ cls isMeta ifTrue:[
+ Smalltalk allClassesDo:[:aClass |
+ aClass class == cls ifTrue:[
+ browser := self class browseClass:aClass.
+ browser classProtocol.
+ ^ self
+ ].
+ ].
+ self warn:'oops, no class for this metaclass'.
+ ^ self
+ ].
+ self class browseClass:cls
]
!
@@ -2770,7 +2800,7 @@
"create a new HierarchyBrowser browsing current class"
self doClassMenuWithSelection:[:cls |
- self class browseClassHierarchy:cls
+ self class browseClassHierarchy:cls
]
!
@@ -2780,10 +2810,10 @@
|subs|
self doClassMenuWithSelection:[:cls |
- subs := cls allSubclasses.
- (subs notNil and:[subs size ~~ 0]) ifTrue:[
- self class browseClasses:subs title:('subclasses of ' , cls name)
- ]
+ subs := cls allSubclasses.
+ (subs notNil and:[subs size ~~ 0]) ifTrue:[
+ self class browseClasses:subs title:('subclasses of ' , cls name)
+ ]
]
!
@@ -2791,9 +2821,9 @@
|printStream|
self doClassMenu:[
- printStream := Printer new.
- currentClass printOutFullProtocolOn:printStream.
- printStream close
+ printStream := Printer new.
+ currentClass printOutFullProtocolOn:printStream.
+ printStream close
]
!
@@ -2801,9 +2831,9 @@
|printStream|
self doClassMenu:[
- printStream := Printer new.
- currentClass printOutProtocolOn:printStream.
- printStream close
+ printStream := Printer new.
+ currentClass printOutProtocolOn:printStream.
+ printStream close
]
!
@@ -2811,23 +2841,22 @@
|printStream|
self doClassMenu:[
- printStream := Printer new.
- currentClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classBinaryFileOut
- self doClassMenu:[
- currentClass binaryFileOut
+ printStream := Printer new.
+ currentClass printOutOn:printStream.
+ printStream close
]
!
classFileOut
self doClassMenu:[
- self label:('System Browser saving: ' , currentClass name).
- currentClass fileOut.
- self label:'System Browser'
+ self label:('System Browser saving: ' , currentClass name).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ currentClass fileOut.
+ ].
+ self label:'System Browser'
]
!
@@ -2837,15 +2866,16 @@
|aStream|
self doClassMenu:[
- aStream := WriteStream on:(String new:200).
- actualClass printHierarchyOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:nil.
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ aStream := WriteStream on:(String new:200).
+ actualClass printHierarchyOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:nil.
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #hierarchy
]
!
@@ -2856,26 +2886,27 @@
|aStream|
self doClassMenu:[
- aStream := WriteStream on:(String new:200).
- currentClass fileOutDefinitionOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- ]
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ aStream := WriteStream on:(String new:200).
+ currentClass fileOutDefinitionOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ ]
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #definition
]
!
@@ -2886,23 +2917,23 @@
|s|
self doClassMenu:[
- s := WriteStream on:(String new).
- currentClass fileOutClassInstVarDefinitionOn:s.
- codeView contents:(s contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- Compiler evaluate:theCode asString notifying:codeView.
- codeView modified:false.
- self updateClassList.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ s := WriteStream on:(String new).
+ currentClass fileOutClassInstVarDefinitionOn:s.
+ codeView contents:(s contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ Compiler evaluate:theCode asString notifying:codeView.
+ codeView modified:false.
+ self updateClassList.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
]
!
@@ -2914,18 +2945,25 @@
"show the classes comment in the codeView"
self doClassMenu:[
- codeView contents:(currentClass comment).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- Object abortSignal catch:[
- currentClass comment:theCode asString.
- codeView modified:false.
- ]
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ]
+ codeView contents:(currentClass comment).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ Object abortSignal catch:[
+ currentClass comment:theCode asString.
+ codeView modified:false.
+ ]
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #comment
+ ]
+!
+
+classRefs
+ self doClassMenu:[
+ self class browseReferendsOf:currentClass name asSymbol
]
!
@@ -2933,15 +2971,17 @@
"show an enterbox for instvar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aString |
- self withWaitCursorDo:[
- self class browseInstRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aString |
+ self withWaitCursorDo:[
+ self class browseInstRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
]
!
@@ -2949,29 +2989,31 @@
"show an enterbox for instVar to search for"
self classInstVarRefsOrModsTitle:'instance variable to browse references to:'
- mods:false
+ mods:false
!
classInstVarMods
"show an enterbox for instVar to search for"
self classInstVarRefsOrModsTitle:'instance variable to browse modifications of:'
- mods:true
+ mods:true
!
classClassVarRefsOrModsTitle:title mods:mods
"show an enterbox for classVar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aString |
- self withWaitCursorDo:[
- self class browseClassRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aString |
+ self withWaitCursorDo:[
+ self class browseClassRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
]
!
@@ -2979,33 +3021,35 @@
"show an enterbox for classVar to search for"
self classClassVarRefsOrModsTitle:'class variable to browse modifications of:'
- mods:true
+ mods:true
!
classClassVarRefs
"show an enterbox for classVar to search for"
self classClassVarRefsOrModsTitle:'class variable to browse references to:'
- mods:false
+ mods:false
!
classAllClassOrInstVarRefsTitle:title access:access
"show an enterbox for instVar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aVariableName |
- self withWaitCursorDo:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:false
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:false
+ ]
+ ].
+ box showAtPointer
]
!
@@ -3013,33 +3057,35 @@
"show an enterbox for instVar to search for"
self classAllClassOrInstVarRefsTitle:'instance variable to browse references to:'
- access:#instVarNames
+ access:#instVarNames
!
classAllClassVarRefs
"show an enterbox for classVar to search for"
self classAllClassOrInstVarRefsTitle:'class variable to browse references to:'
- access:#classVarNames
+ access:#classVarNames
!
classAllInstOrClassVarModsTitle:title access:access
"show an enterbox for instVar to search for"
self doClassMenu:[
- self enterBoxForCodeSelectionTitle:title okText:'browse'.
- enterBox action:[:aVariableName |
- self withWaitCursorDo:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:true
- ]
- ].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ box action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:true
+ ]
+ ].
+ box showAtPointer
]
!
@@ -3047,14 +3093,14 @@
"show an enterbox for instVar to search for"
self classAllInstOrClassVarModsTitle:'instance variable to browse modifications of:'
- access:#instVarNames.
+ access:#instVarNames.
!
classAllClassVarMods
"show an enterbox for classVar to search for"
self classAllInstOrClassVarModsTitle:'class variable to browse modifications of:'
- access:#classVarNames.
+ access:#classVarNames.
!
classClassDefinitionTemplateFor:name in:cat
@@ -3067,27 +3113,27 @@
classListView deselect.
fullClass ifFalse:[
- methodCategoryListView contents:nil.
- methodListView contents:nil
+ methodCategoryListView contents:nil.
+ methodListView contents:nil
].
codeView contents:(self templateFor:name in:cat).
codeView modified:false.
codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- |cl|
-
- cl := (Compiler evaluate:theCode asString notifying:codeView).
- cl isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- self switchToClassNamed:(cl name)
- ]
- ].
- codeView cursor:(Cursor normal).
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ |cl|
+
+ cl := (Compiler evaluate:theCode asString notifying:codeView).
+ cl isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ self switchToClassNamed:(cl name)
+ ]
+ ].
+ codeView cursor:(Cursor normal).
].
codeView explainAction:nil.
self switchToClass:nil
@@ -3099,119 +3145,112 @@
|nm|
currentClass notNil ifTrue:[
- nm := currentClass superclass name
+ nm := currentClass superclass name
] ifFalse:[
- nm := 'Object'
+ nm := 'Object'
].
- self classClassDefinitionTemplateFor:nm in:currentClassCategory
+ self classClassDefinitionTemplateFor:nm in:currentClassCategory.
+ aspect := nil
!
classNewSubclass
"create a subclass-definition prototype in codeview"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self classClassDefinitionTemplateFor:(currentClass name)
- in:(currentClass category)
+ self doClassMenu:[
+ self classClassDefinitionTemplateFor:(currentClass name)
+ in:(currentClass category).
+ aspect := nil
+ ]
!
renameCurrentClassTo:aString
"helper - do the rename"
self doClassMenu:[
- |oldName oldSym newSym|
-
- oldName := currentClass name.
- oldSym := oldName asSymbol.
+ |oldName oldSym newSym|
+
+ oldName := currentClass name.
+ oldSym := oldName asSymbol.
"
- currentClass setName:aString.
- newSym := aString asSymbol.
- Smalltalk at:oldSym put:nil.
- Smalltalk removeKey:oldSym.
- Smalltalk at:newSym put:currentClass.
+ currentClass setName:aString.
+ newSym := aString asSymbol.
+ Smalltalk at:oldSym put:nil.
+ Smalltalk removeKey:oldSym.
+ Smalltalk at:newSym put:currentClass.
"
"
- currentClass renameTo:aString.
+ currentClass renameTo:aString.
"
- Smalltalk renameClass:currentClass to:aString.
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self withWaitCursorDo:[
- Transcript showCr:('searching for users of ' , oldSym); endEntry.
- self class browseReferendsOf:oldSym warnIfNone:false
- ]
+ Smalltalk renameClass:currentClass to:aString.
+
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self withWaitCursorDo:[
+ Transcript showCr:('searching for users of ' , oldSym); endEntry.
+ self class browseReferendsOf:oldSym warnIfNone:false
+ ]
]
!
classRename
"launch an enterBox for new name and query user"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
- enterBox initialText:(currentClass name).
- enterBox action:[:aString | self renameCurrentClassTo:aString].
- enterBox showAtPointer
-!
-
-doRemoveCurrentClass
- "after querying user - do really remove current class
- and all subclasses"
-
- self doClassMenu:[
- currentClass allSubclassesDo:[:aSubClass |
- Smalltalk removeClass:aSubClass
- ].
- Smalltalk removeClass:currentClass.
-
- self switchToClass:nil.
- Smalltalk changed.
- self updateClassList.
-
- "if it was the last in its category, update class category list"
-"
- classListView numberOfLines == 0 ifTrue:[
- self updateClassCategoryListWithScroll:false
- ].
-"
- methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
- methodListView notNil ifTrue:[methodListView contents:nil].
- codeView contents:nil.
- codeView modified:false
- ]
+ |box|
+
+ self checkClassSelected ifFalse:[^ self].
+ box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
+ box initialText:(currentClass name).
+ box action:[:aString | self renameCurrentClassTo:aString].
+ box showAtPointer
!
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
- |count t|
+ |count t box|
currentClass notNil ifTrue:[
- count := 0.
- currentClass allSubclassesDo:[:aSubClass |
- count := count + 1
- ].
- t := 'remove ' , currentClass name.
- count ~~ 0 ifTrue:[
- t := t , '\(with ' , count printString.
- count == 1 ifTrue:[
- t := t , ' subclass'
- ] ifFalse:[
- t := t , ' subclasses'
- ].
- t := (t , ')') withCRs
- ].
- questBox isNil ifTrue:[questBox := YesNoBox title:''].
- questBox title:t.
- questBox yesAction:[self doRemoveCurrentClass].
- questBox okText:(resources at:'remove').
- questBox noText:(resources at:'abort').
- questBox showAtPointer
+ count := currentClass allSubclasses size.
+ t := 'remove ' , currentClass name.
+ count ~~ 0 ifTrue:[
+ t := t , '\(with ' , count printString , ' subclass'.
+ count ~~ 1 ifTrue:[
+ t := t , 'es'
+ ].
+ t := (t , ')') withCRs
+ ].
+ box := YesNoBox
+ title:t
+ yesText:(resources at:'remove')
+ noText:(resources at:'abort').
+ box confirm ifTrue:[
+ "after querying user - do really remove current class
+ and all subclasses
+ "
+ self doClassMenu:[
+ currentClass allSubclassesDo:[:aSubClass |
+ Smalltalk removeClass:aSubClass
+ ].
+ Smalltalk removeClass:currentClass.
+
+ self switchToClass:nil.
+ Smalltalk changed.
+ self updateClassList.
+
+ "if it was the last in its category, update class category list"
+"
+ classListView numberOfLines == 0 ifTrue:[
+ self updateClassCategoryListWithScroll:false
+ ].
+"
+ methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
+ methodListView notNil ifTrue:[methodListView contents:nil].
+ codeView contents:nil.
+ codeView modified:false
+ ]
+ ]
]
! !
@@ -3221,75 +3260,75 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'fileOut all'
- 'printOut'
- '-'
- 'spawn'
- 'spawn category'
- '-'
- 'find method here ...'
- 'find method ...'
- '-'
- 'new category ...'
- 'copy category ...'
- 'create access methods'
- 'rename ...'
- 'remove').
+ 'fileOut'
+ 'fileOut all'
+ 'printOut'
+ '-'
+ 'SPAWN_METHODCATEGORY'
+ 'spawn category'
+ '-'
+ 'find method here ...'
+ 'find method ...'
+ '-'
+ 'new category ...'
+ 'copy category ...'
+ 'create access methods'
+ 'rename ...'
+ 'remove').
methodCategoryListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(
- methodCategoryFileOut
- methodCategoryFileOutAll
- methodCategoryPrintOut
- nil
- methodCategorySpawn
- methodCategorySpawnCategory
- nil
- methodCategoryFindMethod
- methodCategoryFindAnyMethod
- nil
- methodCategoryNewCategory
- methodCategoryCopyCategory
- methodCategoryCreateAccessMethods
- methodCategoryRename
- methodCategoryRemove)
- receiver:self
- for:methodCategoryListView)
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ methodCategoryFileOut
+ methodCategoryFileOutAll
+ methodCategoryPrintOut
+ nil
+ methodCategorySpawn
+ methodCategorySpawnCategory
+ nil
+ methodCategoryFindMethod
+ methodCategoryFindAnyMethod
+ nil
+ methodCategoryNewCategory
+ methodCategoryCopyCategory
+ methodCategoryCreateAccessMethods
+ methodCategoryRename
+ methodCategoryRemove)
+ receiver:self
+ for:methodCategoryListView)
!
switchToMethodNamed:matchString
|aSelector method cat index classToSearch selectors|
currentClass notNil ifTrue:[
- showInstance ifTrue:[
- classToSearch := currentClass
- ] ifFalse:[
- classToSearch := currentClass class
- ].
- selectors := classToSearch selectorArray.
-
- ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
- index := selectors findFirst:[:element | matchString match:element]
- ] ifFalse:[
- index := selectors indexOf:matchString
- ].
-
- (index ~~ 0) ifTrue:[
- aSelector := selectors at:index.
- method := classToSearch methodArray at:index.
- cat := method category.
- cat isNil ifTrue:[cat := '* all *'].
- methodCategoryListView selectElement:cat.
- currentMethodCategory := cat.
- self methodCategorySelectionChanged.
-
- currentMethod := classToSearch compiledMethodAt:aSelector.
- methodListView selectElement:aSelector.
- self methodSelectionChanged
- ]
+ showInstance ifTrue:[
+ classToSearch := currentClass
+ ] ifFalse:[
+ classToSearch := currentClass class
+ ].
+ selectors := classToSearch selectorArray.
+
+ ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
+ index := selectors findFirst:[:element | matchString match:element]
+ ] ifFalse:[
+ index := selectors indexOf:matchString
+ ].
+
+ (index ~~ 0) ifTrue:[
+ aSelector := selectors at:index.
+ method := classToSearch methodArray at:index.
+ cat := method category.
+ cat isNil ifTrue:[cat := '* all *'].
+ methodCategoryListView selectElement:cat.
+ currentMethodCategory := cat.
+ self methodCategorySelectionChanged.
+
+ currentMethod := classToSearch compiledMethodAt:aSelector.
+ methodListView selectElement:aSelector.
+ self methodSelectionChanged
+ ]
]
!
@@ -3298,54 +3337,54 @@
aSelector := aString asSymbol.
currentClass isNil ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- classToStartSearch := currentClassHierarchy
- ]
+ currentClassHierarchy notNil ifTrue:[
+ classToStartSearch := currentClassHierarchy
+ ]
] ifFalse:[
- classToStartSearch := currentClass
+ classToStartSearch := currentClass
].
classToStartSearch notNil ifTrue:[
- showInstance ifFalse:[
- classToStartSearch := classToStartSearch class
- ].
- aClass := classToStartSearch whichClassImplements:aSelector.
- aClass notNil ifTrue:[
- nm := aClass name.
- showInstance ifFalse:[
- ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
- nm := nm copyTo:(nm size - 5)
- ]
- ].
- self switchToClassNamed:nm.
- self switchToMethodNamed:aString
- ]
+ showInstance ifFalse:[
+ classToStartSearch := classToStartSearch class
+ ].
+ aClass := classToStartSearch whichClassImplements:aSelector.
+ aClass notNil ifTrue:[
+ nm := aClass name.
+ showInstance ifFalse:[
+ ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
+ nm := nm copyTo:(nm size - 5)
+ ]
+ ].
+ self switchToClassNamed:nm.
+ self switchToMethodNamed:aString
+ ]
]
!
copyMethodsFromClass:aClassName
- |class|
+ |class box|
currentClass notNil ifTrue:[
- Symbol hasInterned:aClassName ifTrue:[:sym |
- (Smalltalk includesKey:sym) ifTrue:[
- class := Smalltalk at:sym
- ].
- ].
- class isBehavior ifFalse:[
- self warn:(resources string:'no class named %1' with:aClassName).
- ^ self
- ].
-
- showInstance ifFalse:[
- class := class class
- ].
-
- "show enterbox for category to copy from"
-
- self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
- okText:'copy'.
- enterBox action:[:aString | self copyMethodsFromClass:class category:aString].
- enterBox showAtPointer
+ Symbol hasInterned:aClassName ifTrue:[:sym |
+ (Smalltalk includesKey:sym) ifTrue:[
+ class := Smalltalk at:sym
+ ].
+ ].
+ class isBehavior ifFalse:[
+ self warn:'no class named %1' with:aClassName.
+ ^ self
+ ].
+
+ showInstance ifFalse:[
+ class := class class
+ ].
+
+ "show enterbox for category to copy from"
+
+ box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
+ okText:'copy'.
+ box action:[:aString | self copyMethodsFromClass:class category:aString].
+ box showAtPointer.
]
!
@@ -3353,50 +3392,49 @@
|source|
currentClass notNil ifTrue:[
- codeView abortAction:[^ self].
- class methodArray do:[:aMethod |
- (category match:aMethod category) ifTrue:[
- source := aMethod source.
- codeView contents:source.
- codeView modified:false.
- actualClass compiler compile:source
- forClass:actualClass
- inCategory:aMethod category
- notifying:codeView.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- ]
- ]
+"/ codeView abortAction:[^ self].
+ Object abortSignal catch:[
+ class methodArray do:[:aMethod |
+ (category match:aMethod category) ifTrue:[
+ source := aMethod source.
+ codeView contents:source.
+ codeView modified:false.
+ actualClass compiler compile:source
+ forClass:actualClass
+ inCategory:aMethod category
+ notifying:codeView.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ ]
+ ]
+ ]
]
!
methodCategoryFindMethod
- self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- enterBox action:[:aString | self switchToMethodNamed:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ box action:[:aString | self switchToMethodNamed:aString].
+ box showAtPointer
!
methodCategoryFindAnyMethod
- self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- enterBox action:[:aString | self switchToAnyMethodNamed:aString].
- enterBox showAtPointer
+ |box|
+
+ box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ box action:[:aString | self switchToAnyMethodNamed:aString].
+ box showAtPointer
!
methodCategoryPrintOut
|printStream|
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
- ].
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- printStream := Printer new.
- actualClass printOutCategory:currentMethodCategory on:printStream.
- printStream close
- ]
+ self checkClassSelected ifFalse:[^ self].
+ self whenMethodCategorySelected:[
+ printStream := Printer new.
+ actualClass printOutCategory:currentMethodCategory on:printStream.
+ printStream close
]
!
@@ -3404,18 +3442,16 @@
"fileOut all methods in the selected methodcategory of
the current class"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
- ].
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
- actualClass fileOutCategory:currentMethodCategory.
- self label:'System Browser'.
- ]
+ self checkClassSelected ifFalse:[^ self].
+ self whenMethodCategorySelected:[
+ self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ actualClass fileOutCategory:currentMethodCategory.
+ ].
+ self label:'System Browser'.
]
!
@@ -3423,49 +3459,61 @@
"fileOut all methods in the selected methodcategory of
the current class"
- |fileName project outStream hasMethodsInThisCategory|
-
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
- ].
- fileName := currentMethodCategory , '.st'.
- fileName replaceAll:Character space by:$_.
- "
- this test allows a smalltalk to be built without Projects/ChangeSets
- "
- Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
- ].
- outStream := FileStream newFileNamed:fileName.
- outStream isNil ifTrue:[
- ^ self warn:(resources string:'cannot create: %1' with:fileName)
- ].
- self withWaitCursorDo:[
- self label:('System Browser saving: ' , currentMethodCategory).
- Smalltalk allClassesDo:[:class |
- hasMethodsInThisCategory := false.
- class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ].
- hasMethodsInThisCategory := false.
- class class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ]
- ].
- outStream close.
- self label:'System Browser'.
+
+ self whenMethodCategorySelected:[
+ |fileName outStream|
+
+ fileName := currentMethodCategory , '.st'.
+ fileName replaceAll:Character space by:$_.
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory , fileName.
+ ].
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ outStream := FileStream newFileNamed:fileName.
+ outStream isNil ifTrue:[
+ ^ self warn:'cannot create: %1' with:fileName
+ ].
+
+ self label:('System Browser saving: ' , currentMethodCategory).
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return
+ ] do:[
+ Smalltalk allClassesDo:[:class |
+ |hasMethodsInThisCategory|
+
+ hasMethodsInThisCategory := false.
+ class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ].
+ hasMethodsInThisCategory := false.
+ class class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ]
+ ].
+ ].
+ outStream close.
+ self label:'System Browser'.
].
!
@@ -3473,10 +3521,10 @@
"create a new SystemBrowser browsing current method category"
currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:actualClass
- methodCategory:currentMethodCategory
- ]
+ self withWaitCursorDo:[
+ self class browseClass:actualClass
+ methodCategory:currentMethodCategory
+ ]
]
!
@@ -3484,26 +3532,24 @@
"create a new SystemBrowser browsing all methods from all
classes with same category as current method category"
- self enterBoxForMethodCategory:'category to browse methods:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseMethodCategory:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseMethodCategory:'category to browse methods:'
+ action:[:aString |
+ self class browseMethodCategory:aString
+ ]
!
newMethodCategory:aString
|categories|
currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
+ ^ self warn:'select/create a class first'.
].
categories := methodCategoryListView list.
categories isNil ifTrue:[categories := Text new].
(categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- methodCategoryListView contents:categories
+ categories add:aString.
+ categories sort.
+ methodCategoryListView contents:categories
].
currentMethodCategory := aString.
self methodCategorySelectionChanged
@@ -3512,34 +3558,34 @@
methodCategoryNewCategory
"show the enter box to add a new method category"
- |someCategories existingCategories|
+ |someCategories existingCategories box|
"a tiny little goody here ..."
showInstance ifTrue:[
- someCategories := #('accessing'
- 'initialization'
- 'private'
- 'printing & storing'
- 'queries'
- 'testing'
- )
+ someCategories := #('accessing'
+ 'initialization'
+ 'private'
+ 'printing & storing'
+ 'queries'
+ 'testing'
+ )
] ifFalse:[
- someCategories := #(
- 'documentation'
- 'initialization'
- 'instance creation'
- ).
+ someCategories := #(
+ 'documentation'
+ 'initialization'
+ 'instance creation'
+ ).
].
existingCategories := methodCategoryListView list.
existingCategories notNil ifTrue:[
- someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
+ someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
].
- self listBoxTitle:(resources at:'name of new method category:')
- okText:(resources at:'create')
- list:someCategories.
- selectBox action:[:aString | self newMethodCategory:aString].
- selectBox showAtPointer
+ box := self listBoxTitle:'name of new method category:'
+ okText:'create'
+ list:someCategories.
+ box action:[:aString | self newMethodCategory:aString].
+ box showAtPointer
!
methodCategoryCreateAccessMethods
@@ -3547,133 +3593,116 @@
|source|
- currentClass isNil ifTrue:[^ self].
+ self checkClassSelected ifFalse:[^ self].
+
showInstance ifFalse:[
- self warn:(resources string:'select instance - and try again').
- ^ self.
+ self warn:'select instance - and try again'.
+ ^ self.
].
+
self withWaitCursorDo:[
- currentClass instVarNames do:[:name |
- "check, if method is not already present"
- (currentClass implements:(name asSymbol)) ifFalse:[
- source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ''' already present'
- ].
- (currentClass implements:((name , ':') asSymbol)) ifFalse:[
- source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ':'' already present'
- ].
- ].
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
+ currentClass instVarNames do:[:name |
+ "check, if method is not already present"
+ (currentClass implements:(name asSymbol)) ifFalse:[
+ source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ''' already present'
+ ].
+ (currentClass implements:((name , ':') asSymbol)) ifFalse:[
+ source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ':'' already present'
+ ].
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
]
!
methodCategoryCopyCategory
"show the enter box to copy from an existing method category"
- |title|
+ |title box|
showInstance ifTrue:[
- title := 'class to copy instance method category from:'
+ title := 'class to copy instance method category from:'
] ifFalse:[
- title := 'class to copy class method category from:'
+ title := 'class to copy class method category from:'
].
- self listBoxTitle:title
- okText:'ok'
- list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
-
- selectBox action:[:aString | self copyMethodsFromClass:aString].
- selectBox showAtPointer
-!
-
-renameCurrentMethodCategoryTo:aString
- "helper - do the rename"
-
- currentMethodCategory notNil ifTrue:[
- actualClass renameCategory:currentMethodCategory to:aString.
-
-"/ actualClass methodArray do:[:aMethod |
-"/ aMethod category = currentMethodCategory ifTrue:[
-"/ aMethod category:aString
-"/ ]
-"/ ].
- currentMethodCategory := aString.
- currentMethod := nil.
- self updateMethodCategoryList.
- self updateMethodListWithScroll:false
- ]
+ box := self listBoxTitle:title
+ okText:'ok'
+ list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
+
+ box action:[:aString | self copyMethodsFromClass:aString].
+ box showAtPointer
!
methodCategoryRename
"launch an enterBox to rename current method category"
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select a method category first'.
+ |box|
+
+ self checkMethodCategorySelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
+ okText:(resources at:'rename').
+ box initialText:currentMethodCategory.
+ box action:[:aString |
+ actualClass renameCategory:currentMethodCategory to:aString.
+ currentMethodCategory := aString.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodListWithScroll:false
].
-
- self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
- okText:(resources at:'rename').
- enterBox initialText:currentMethodCategory.
- enterBox action:[:aString | self renameCurrentMethodCategoryTo:aString].
- enterBox showAtPointer
-!
-
-doMethodCategoryRemove
- "actually remove all methods from current method category"
-
- currentMethodCategory notNil ifTrue:[
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- actualClass
- removeSelector:(actualClass selectorForMethod:aMethod)
- ]
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
- self updateMethodCategoryList.
- self updateMethodList
- ]
+ box showAtPointer
!
methodCategoryRemove
"show number of methods to remove and query user"
- |count t|
+ |count t box|
currentMethodCategory notNil ifTrue:[
- count := 0.
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- count := count + 1
- ]
- ].
- (count == 0) ifTrue:[
- currentMethodCategory := nil.
- currentMethod := nil.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodList
- ] ifFalse:[
- (count == 1) ifTrue:[
- t := resources string:'remove %1 ?\(with 1 method)' with:currentMethodCategory
- ] ifFalse:[
- t := resources string:'remove %1 ?\(with %2 methods)' with:currentMethodCategory
- with:count printString.
- ].
- t := t withCRs.
-
- questBox isNil ifTrue:[questBox := YesNoBox title:''].
- questBox title:t.
- questBox yesAction:[self doMethodCategoryRemove].
- questBox okText:(resources at:'remove').
- questBox noText:(resources at:'abort').
- questBox showAtPointer
- ]
+ count := 0.
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ count := count + 1
+ ]
+ ].
+ (count == 0) ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodList
+ ] ifFalse:[
+ (count == 1) ifTrue:[
+ t := resources string:'remove %1 ?\(with 1 method)' with:currentMethodCategory
+ ] ifFalse:[
+ t := resources string:'remove %1 ?\(with %2 methods)' with:currentMethodCategory
+ with:count printString.
+ ].
+ t := t withCRs.
+
+ box := YesNoBox
+ title:t
+ yesText:(resources at:'remove')
+ noText:(resources at:'abort').
+ box confirm ifTrue:[
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ actualClass
+ removeSelector:(actualClass selectorForMethod:aMethod)
+ ]
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodList
+ ]
+ ]
]
! !
@@ -3683,64 +3712,64 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'printOut'
- '-'
- 'spawn'
- '-'
- 'senders ...'
- 'implementors ...'
- 'globals ...'
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
"
- 'strings ...'
- 'apropos ...'
+ 'strings ...'
+ 'apropos ...'
"
- '-'
- 'local senders ...'
- 'local implementors ...'
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
"
- 'local strings ...'
+ 'local strings ...'
"
- '-'
- 'breakpoint'
- 'trace'
- 'trace sender'
- '-'
- 'new method'
- 'change category ...'
- 'remove').
+ '-'
+ 'breakpoint'
+ 'trace'
+ 'trace sender'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
methodListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
"
- methodStringSearch
- methodAproposSearch
+ methodStringSearch
+ methodAproposSearch
"
- nil
- methodLocalSenders
- methodLocalImplementors
+ nil
+ methodLocalSenders
+ methodLocalImplementors
"
- methodLocalStringSearch
+ methodLocalStringSearch
"
- nil
- methodBreakPoint
- methodTrace
- methodTraceSender
- nil
- methodNewMethod
- methodChangeCategory
- methodRemove)
- receiver:self
- for:methodListView)
+ nil
+ methodBreakPoint
+ methodTrace
+ methodTraceSender
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
!
initializeMethodMenu2
@@ -3748,60 +3777,60 @@
methodListView isNil ifTrue:[^ self].
labels := resources array:#(
- 'fileOut'
- 'printOut'
- '-'
- 'spawn'
- '-'
- 'senders ...'
- 'implementors ...'
- 'globals ...'
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
"
- 'strings ...'
- 'apropos ...'
+ 'strings ...'
+ 'apropos ...'
"
- '-'
- 'local senders ...'
- 'local implementors ...'
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
"
- 'local strings ...'
+ 'local strings ...'
"
- '-'
- 'remove break/trace'
- '-'
- 'new method'
- 'change category ...'
- 'remove').
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
methodListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
"
- methodStringSearch
- methodAproposSearch
+ methodStringSearch
+ methodAproposSearch
"
- nil
- methodLocalSenders
- methodLocalImplementors
+ nil
+ methodLocalSenders
+ methodLocalImplementors
"
- methodLocalStringSearch
+ methodLocalStringSearch
"
- nil
- methodRemoveBreakOrTrace
- nil
- methodNewMethod
- methodChangeCategory
- methodRemove)
- receiver:self
- for:methodListView)
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
!
methodPrintOut
@@ -3809,9 +3838,8 @@
|printStream|
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
+ self checkMethodSelected ifFalse:[^ self].
+
printStream := Printer new.
actualClass printOutSource:currentMethod source on:printStream.
printStream close
@@ -3820,110 +3848,91 @@
methodFileOut
"file out the current method"
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
+ self checkMethodSelected ifFalse:[^ self].
+
+ self label:'System Browser saving'.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return
+ ] do:[
+ actualClass fileOutMethod:currentMethod.
].
- self label:'System Browser saving'.
- actualClass fileOutMethod:currentMethod.
self label:'System Browser'.
!
methodImplementors
"launch an enterBox for selector to search for"
- self enterBoxForBrowseSelectorTitle:'selector to browse implementors of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseImplementorsOf:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'selector to browse implementors of:'
+ action:[:aString |
+ self class browseImplementorsOf:aString
+ ]
!
methodLocalImplementors
"launch an enterBox for selector to search for"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
-
- self enterBoxForBrowseSelectorTitle:'selector to browse local implementors of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseImplementorsOf:aString under:currentClass
- ]
- ].
- enterBox showAtPointer
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'selector to browse local implementors of:'
+ action:[:aString |
+ self class browseImplementorsOf:aString under:currentClass
+ ]
!
methodSenders
"launch an enterBox for selector to search for"
- self enterBoxForBrowseSelectorTitle:'selector to browse senders of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseAllCallsOn:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'selector to browse senders of:'
+ action:[:aString |
+ self class browseAllCallsOn:aString
+ ]
!
methodLocalSenders
"launch an enterBox for selector to search for in current class & subclasses"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self enterBoxForBrowseSelectorTitle:'selector to browse local senderss of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseCallsOn:aString under:currentClass
- ]
- ].
- enterBox showAtPointer
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'selector to browse local senderss of:'
+ action:[:aString |
+ self class browseCallsOn:aString under:currentClass
+ ]
!
methodGlobalReferends
"launch an enterBox for global symbol to search for"
- self enterBoxForBrowseTitle:'global variable to browse users of:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseReferendsOf:aString asSymbol
- ]
- ].
- enterBox showAtPointer
+ self enterBoxForBrowseTitle:'global variable to browse users of:'
+ action:[:aString |
+ self class browseReferendsOf:aString asSymbol
+ ]
!
methodStringSearch
"launch an enterBox for (sub)-string to search for"
- self enterBoxForBrowseSelectorTitle:'string / matchString to search for:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseForString:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'string / matchString to search for:'
+ action:[:aString |
+ self class browseForString:aString
+ ]
!
methodLocalStringSearch
"launch an enterBox for (sub)-string to search for"
- currentClass isNil ifTrue:[
- ^ self warn:'select a class first'.
- ].
- self enterBoxForBrowseSelectorTitle:'string / matchString to search for locally:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class browseForString:aString in:(currentClass withAllSubclasses)
- ]
- ].
- enterBox showAtPointer
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'string / matchString to search for locally:'
+ action:[:aString |
+ self class browseForString:aString in:(currentClass withAllSubclasses)
+ ]
!
methodAproposSearch
"launch an enterBox for a keyword search"
- self enterBoxForBrowseSelectorTitle:'keyword to search for:'.
- enterBox action:[:aString | self withWaitCursorDo:[
- self class aproposSearch:aString
- ]
- ].
- enterBox showAtPointer
+ self askAndBrowseSelectorTitle:'keyword to search for:'
+ action:[:aString |
+ self class aproposSearch:aString
+ ]
!
methodSpawn
@@ -3931,74 +3940,76 @@
or if the current selection is of the form 'class>>selector', spwan
a browser on that method."
- |s sel clsName cls browseMeta w sep|
+ |s sel selSymbol clsName clsSymbol cls meta browseMeta w sep|
sel := codeView selection.
sel notNil ifTrue:[
- sel := sel asString withoutSeparators.
- ('*>>*' match:sel) ifTrue:[
- sep := $>
- ] ifFalse:[
- ('* *' match:sel) ifTrue:[
- sep := Character space
- ]
- ].
- sep notNil ifTrue:[
- s := ReadStream on:sel.
- clsName := s upTo:sep.
- [s peek == sep] whileTrue:[s next].
- sel := s upToEnd.
- (clsName endsWith:'class') ifTrue:[
- browseMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- browseMeta := false
- ].
- (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
- (Smalltalk includesKey:clsName asSymbol) ifTrue:[
- cls := Smalltalk at:clsName asSymbol.
- browseMeta ifTrue:[
- cls := cls class
- ].
- cls isBehavior ifFalse:[
- cls := cls class
- ].
- cls isBehavior ifTrue:[
- (cls implements:sel asSymbol) ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:cls selector:sel asSymbol
- ].
- ^ self
- ] ifFalse:[
- (cls class implements:sel asSymbol) ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:cls class selector:sel asSymbol
- ].
- ^ self
- ] ifFalse:[
- w := clsName , ' does not implement #' , sel
- ]
- ]
- ] ifFalse:[
- w := clsName , ' is not a class'
- ]
- ] ifFalse:[
- w := clsName , ' is unknown'
- ]
- ] ifFalse:[
- w := clsName , ' and/or ' , sel , ' is unknown'
- ].
- self warn:w.
- ^ self
- ].
+ sel := sel asString withoutSeparators.
+ ('*>>*' match:sel) ifTrue:[
+ sep := $>
+ ] ifFalse:[
+ ('* *' match:sel) ifTrue:[
+ sep := Character space
+ ]
+ ].
+ sep notNil ifTrue:[
+ "
+ extract class/sel from selection
+ "
+ s := ReadStream on:sel.
+ clsName := s upTo:sep.
+ [s peek == sep] whileTrue:[s next].
+ sel := s upToEnd.
+
+ (clsName endsWith:'class') ifTrue:[
+ browseMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ browseMeta := false
+ ].
+ (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
+ clsSymbol := clsName asSymbol.
+ (Smalltalk includesKey:clsSymbol) ifTrue:[
+ cls := Smalltalk at:clsSymbol.
+ browseMeta ifTrue:[
+ cls := cls class
+ ].
+ cls isBehavior ifFalse:[
+ cls := cls class
+ ].
+ cls isBehavior ifTrue:[
+ selSymbol := sel asSymbol.
+ self withWaitCursorDo:[
+ (cls implements:selSymbol) ifTrue:[
+ self class browseClass:cls selector:selSymbol.
+ ^ self
+ ] ifFalse:[
+ meta := cls class.
+ (meta implements:selSymbol) ifTrue:[
+ self class browseClass:meta selector:selSymbol.
+ ^ self
+ ].
+ w := ' does not implement #' , sel
+ ]
+ ]
+ ] ifFalse:[
+ w := ' is not a class'
+ ]
+ ] ifFalse:[
+ w := ' is unknown'
+ ]
+ ] ifFalse:[
+ w := ' and/or ' , sel , ' is unknown'
+ ].
+ self warn:(clsName , w).
+ ^ self
+ ].
].
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
+ self checkMethodSelected ifFalse:[^ self].
self withWaitCursorDo:[
- self class browseClass:actualClass
- selector:(actualClass selectorForMethod:currentMethod)
+ self class browseClass:actualClass
+ selector:(actualClass selectorForMethod:currentMethod)
]
!
@@ -4007,10 +4018,10 @@
code view and define accept-action to compile it"
currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
+ ^ self warn:'select/create a class first'.
].
currentMethodCategory isNil ifTrue:[
- ^ self warn:'select/create a method category first'.
+ ^ self warn:'select/create a method category first'.
].
currentMethod := nil.
@@ -4020,44 +4031,29 @@
codeView modified:false.
codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
]
!
methodRemove
"remove the current method"
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
- actualClass
- removeSelector:(actualClass selectorForMethod:currentMethod).
- self updateMethodListWithScroll:false
-!
-
-doChangeCategoryOfCurrentMethodTo:aString
- "after querying user - do really change current methods category"
-
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
- currentMethod category:aString asSymbol.
- currentClass changed.
- self updateMethodCategoryListWithScroll:false.
+ self checkMethodSelected ifFalse:[^ self].
+ actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
self updateMethodListWithScroll:false
!
@@ -4066,20 +4062,27 @@
nothing done here, but a query for the new category.
Remember the last category, to allow faster category change of a group of methods."
- currentMethod isNil ifTrue:[
- ^ self warn:'select a method first'.
- ].
- self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
- okText:'change'.
+ |box txt|
+
+ self checkMethodSelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
+ okText:'change'.
lastMethodCategory isNil ifTrue:[
- enterBox initialText:(currentMethod category).
+ txt := currentMethod category.
] ifFalse:[
- enterBox initialText:lastMethodCategory
+ txt := lastMethodCategory
].
- enterBox action:[:aString | lastMethodCategory := aString.
- self doChangeCategoryOfCurrentMethodTo:aString
- ].
- enterBox showAtPointer
+ box initialText:txt.
+ box action:[:aString |
+ lastMethodCategory := aString.
+
+ currentMethod category:aString asSymbol.
+ currentClass changed.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+ ].
+ box showAtPointer
!
methodRemoveBreakOrTrace
@@ -4088,13 +4091,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifTrue:[
- currentMethod := MessageTracer unwrapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- self initializeMethodMenu
- ].
+ currentMethod isWrapped ifTrue:[
+ currentMethod := MessageTracer unwrapMethod:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ self initializeMethodMenu
+ ].
]
!
@@ -4104,13 +4107,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer trapMethod:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer trapMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
]
!
@@ -4120,13 +4123,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethod:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
]
!
@@ -4136,13 +4139,13 @@
|sel|
currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethodSender:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethodSender:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
]
! !
@@ -4152,40 +4155,118 @@
|labels|
labels := resources array:#(
- 'fileOut'
- 'printOut'
- '-'
- 'spawn'
- 'spawn class'
- '-'
- 'sender ...'
- 'implementors ...'
- 'globals ...'
+ 'fileOut'
+ 'fileOut all'
+ 'printOut'
+ '-'
+ 'spawn'
+ 'spawn class'
+ '-'
+ 'sender ...'
+ 'implementors ...'
+ 'globals ...'
"/ '-'
"/ 'breakpoint'
"/ 'trace'
"/ 'trace sender'
- ).
+ ).
classMethodListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(methodFileOut
- methodPrintOut
- nil
- methodSpawn
- classSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ classMethodFileOutAll
+ methodPrintOut
+ nil
+ methodSpawn
+ classSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
"/ nil
"/ methodBreakPoint
"/ methodTrace
"/ methodTraceSender
- )
- receiver:self
- for:classMethodListView)
+ )
+ receiver:self
+ for:classMethodListView)
+!
+
+classMethodFileOutAll
+ "fileout all methods into one source file"
+
+ |list classString selectorString cls mth outStream fileName append
+ fileBox oldLabel|
+
+ append := false.
+ fileBox := FileSaveBox
+ title:(resources string:'save methodss in:')
+ okText:(resources string:'save')
+ abortText:(resources string:'cancel')
+ action:[:fName | fileName := fName].
+ fileBox appendAction:[:fName | fileName := fName. append := true].
+ fileBox initialText:'some_methods.st'.
+ Project notNil ifTrue:[
+ fileBox directory:Project currentProjectDirectory
+ ].
+ fileBox showAtPointer.
+
+ fileName notNil ifTrue:[
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ append ifTrue:[
+ outStream := FileStream appendingOldFileNamed:fileName
+ ] ifFalse:[
+ outStream := FileStream newFileNamed:fileName.
+ ].
+ outStream isNil ifTrue:[
+ ^ self warn:'cannot create: %1' with:fileName
+ ].
+ self withWaitCursorDo:[
+ list := classMethodListView list.
+ oldLabel := label.
+ list do:[:line |
+ self label:('System Browser writing: ' , line).
+
+ classString := self classFromClassMethodString:line.
+ selectorString := self selectorFromClassMethodString:line.
+
+ ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
+ classString := classString copyTo:(classString size - 5).
+ cls := (Smalltalk at:classString asSymbol).
+ cls := cls class
+ ] ifFalse:[
+ cls := (Smalltalk at:classString asSymbol).
+ ].
+
+ cls isNil ifTrue:[
+ self warn:'oops class %1 is gone' with:classString
+ ] ifFalse:[
+ mth := cls compiledMethodAt:(selectorString asSymbol).
+ Class fileOutErrorSignal handle:[:ex |
+ |box|
+ box := YesNoBox new.
+ box yesText:'continue' noText:'abort'.
+ (box confirm:('fileOut error: ' , ex errorString ,
+ '\\continue anyway ?') withCRs) ifTrue:[
+ ex proceed
+ ].
+ self label:'System Browser'.
+ ^ self
+ ] do:[
+ cls fileOutMethod:mth on:outStream.
+ ]
+ ]
+ ].
+ outStream close.
+ self label:oldLabel.
+ ]
+ ]
! !
!SystemBrowser methodsFor:'dependencies'!
@@ -4203,77 +4284,75 @@
oldClassCategory := currentClassCategory.
currentClass notNil ifTrue:[
- oldClassName := currentClass name
+ oldClassName := currentClass name
].
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
methodListView notNil ifTrue:[
- oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
- ]
+ oldMethod notNil ifTrue:[
+ oldSelector := methodListView selectionValue
+ ]
].
classCategoryListView notNil ifTrue:[
- classCategoryListView setContents:(self listOfAllClassCategories).
- oldClassCategory notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ].
- classCategoryListView selection isNil ifTrue:[
- currentClassCategory := nil.
- self switchToClass:nil.
- oldClassName := nil
- ]
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ].
+ classCategoryListView selection isNil ifTrue:[
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ oldClassName := nil
+ ]
].
classListView notNil ifTrue:[
- self updateClassListWithScroll:false.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName
- ].
- classListView selection isNil ifTrue:[
- self switchToClass:nil.
- currentMethodCategory := nil.
- oldMethodCategory := nil
- ]
+ self updateClassListWithScroll:false.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName
+ ].
+ classListView selection isNil ifTrue:[
+ self switchToClass:nil.
+ currentMethodCategory := nil.
+ oldMethodCategory := nil
+ ]
].
methodCategoryListView notNil ifTrue:[
- self updateMethodCategoryListWithScroll:false.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- methodCategoryListView selection isNil ifTrue:[
- currentMethodCategory := nil.
- currentMethod := nil.
- oldSelector := nil
- ]
+ self updateMethodCategoryListWithScroll:false.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ methodCategoryListView selection isNil ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ oldSelector := nil
+ ]
].
methodListView notNil ifTrue:[
- self updateMethodListWithScroll:false.
- oldSelector notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- methodListView selection isNil ifTrue:[
- currentMethod := nil
- ]
+ self updateMethodListWithScroll:false.
+ oldSelector notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ methodListView selection isNil ifTrue:[
+ currentMethod := nil
+ ]
].
self updateCodeView
!
-update:someObject
- (someObject == Smalltalk) ifTrue:[self update. ^ self].
- someObject isBehavior ifTrue:[
- currentClass notNil ifTrue:[
- someObject name = currentClass name ifTrue:[
- currentClass := someObject.
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- self updateMethodCategoryListWithScroll:false.
- "dont update codeView ...."
- "self update"
- ^ self
- ]
- ]
+update:something with:someArgument from:changedObject
+ (changedObject == Smalltalk) ifTrue:[self update. ^ self].
+ changedObject isBehavior ifTrue:[
+ (currentClass notNil and:[changedObject name = currentClass name]) ifTrue:[
+ currentClass := Smalltalk at:(currentClass name asSymbol).
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ "dont update codeView ...."
+ "self update"
+ ^ self
+ ]
]
! !