"

 COPYRIGHT (c) 1989 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.8 on 29-oct-1995 at 20:01:20'                   !

StandardSystemView subclass:#BrowserView

	 instanceVariableNames:'classCategoryListView classListView methodCategoryListView

		methodListView classMethodListView codeView classToggle

		instanceToggle currentClassCategory currentClassHierarchy

		currentClass currentMethodCategory currentMethod currentSelector

		showInstance actualClass fullClass lastMethodCategory aspect

		variableListView fullProtocol lockUpdates autoSearch myLabel

		acceptClass'

	 classVariableNames:'CheckForInstancesWhenRemovingClasses DefaultIcon'

	 poolDictionaries:''

	 category:'Interface-Browsers'

!

!BrowserView class methodsFor:'documentation'!

version

"

"!

documentation

"

    this class implements all kinds of class browsers.

    Typically, it is started with 'SystemBrowser open', but there are many other 

    startup messages, to launch special browsers.

    See the categories 'startup' and 'special search startup' in the classes

    protocol.

    Alse, see the extra document 'doc/misc/sbrowser.doc' or the HTML online doc

    for how to use the browser.

    written winter 89 by claus

    Notice: SystemBrowser is currently being rewritten to be an instance

    of ApplicationModel - this transition is not yet complete and you see

    here intermediate versions of BrowserView/SystemBrowser. 

    All action is (currently) still done here in BrowserView, although the

    SystemBrowsers class methods are used to startup a browser.

    This will certainly change ...

"

!

copyright

"

 COPYRIGHT (c) 1989 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.

"

! !

!BrowserView class methodsFor:'initialization'!

initialize

    "Browser configuration;

     (values can be changed from your private startup file)"

    "

     setting this to false, the removeClass function will remove

     classes WITHOUT checking for instances. Otherwise,

     it will check and let you confirm in case there are instances.

     Checking for instances may be a bit time consuming, though.

     The default is true - therefore, it will check

    "

    CheckForInstancesWhenRemovingClasses := true

    "

     CheckForInstancesWhenRemovingClasses := true

     CheckForInstancesWhenRemovingClasses := false

    "

! !

!BrowserView class methodsFor:'defaults'!

defaultIcon

    DefaultIcon isNil ifTrue:[

	DefaultIcon := Form fromFile:'SBrowser.xbm' resolution:100

    ].

    ^ DefaultIcon

! !

!BrowserView methodsFor:'change & update'!

update:something with:someArgument from:changedObject

    |list|

    "

     avoid update/warn after my own changes

    "

    lockUpdates == true ifTrue:[

"/         'ignored my change' printNL.

	^ self

    ].

"/ changedObject print. ' ' print. someArgument print. ' ' print.

"/ something printNL.

    (changedObject == Smalltalk) ifTrue:[

	something == #newClass ifTrue:[

	    (currentClass notNil

	    and:[someArgument name = currentClass name]) ifTrue:[

		"

		 the current class was autoloaded

		"

		self warnLabel:'the selected class has changed'.

		self updateClassListWithScroll:false.

	    ].

	    ((someArgument category = currentClassCategory)

	    or:[currentClassCategory notNil

		and:[currentClassCategory startsWith:'*']]) ifTrue:[

		self updateClassListWithScroll:false.

	    ].

	    someArgument category ~= currentClassCategory ifTrue:[

		"

		 category new ?

		"

		(classCategoryListView notNil 

		and:[(list := classCategoryListView list) notNil

		and:[(list includes:someArgument category) not]])

		ifTrue:[

		    self updateClassCategoryListWithScroll:false.

		]

	    ].

	    ^ self

	].

	something == #classRemove ifTrue:[

	    someArgument = currentClass ifTrue:[

		self warnLabel:'the selected class was removed'.

		^ self

	    ].

	    " fall into general update "

	].

	"

	 any other (unknown) change 

	 with the Smalltalk dictionary ...

	"

	self updateClassCategoryListWithScroll:false.

	self updateClassListWithScroll:false.

	^ self

    ].

    changedObject isBehavior ifTrue:[

	"

	 its a class, that has changed

	"

	(currentClass notNil 

	and:[changedObject name = currentClass name]) ifTrue:[

	    "

	     its the current class that has changed

	    "

	    something == #methodDictionary ifTrue:[

		(someArgument isSymbol) ifTrue:[

		    |changedMethod|

		    "

		     the method with selector someArgument was changed or removed

		    "

		    self updateMethodCategoryListWithScroll:false.

		    self updateMethodListWithScroll:false.

		    someArgument == currentSelector ifTrue:[

			"

			 special care here: the currently shown method has been

			 changed somehow in another browser (or via fileIn)

			"

			changedMethod := currentClass compiledMethodAt:currentSelector.

			changedMethod isNil ifTrue:[

			    self warnLabel:'the method shown was removed'.

			    ^ self

			].

			"compare the source codes"

			currentMethod notNil ifTrue:[

			    changedMethod source = codeView contents ifFalse:[

				self warnLabel:'the code shown may not up to date'.

			    ]

			].

			^ self    

		    ].

		    ^ self

		]

	    ].

	    something == #comment ifTrue:[

		"

		 the class has changed its comment; we dont care, except if

		 currently showing the comment

		"

		aspect == #comment ifTrue:[

		    self warnLabel:'the comment shown may not up to date'.

		].

		^ self

	    ].

	    something == #definition ifTrue:[

		"

		 the class has changed its definition.

		 Warn, except if showing a method.

		"

		aspect notNil ifTrue:[

		    self warnLabel:'the classes definition has changed'.

		].

"/                ^ self

	    ].

	    "

	     get the class again - in case of a changed class definition,

	     we are otherwise refering to the obsolete old class

	    "

	    currentClass := Smalltalk at:(currentClass name asSymbol).

	    showInstance ifTrue:[

		actualClass := currentClass

	    ] ifFalse:[

		actualClass := currentClass class

	    ].

	    self updateMethodCategoryListWithScroll:false.

	    "dont update codeView ...."

	    "self update"

	    ^ self

	].

	"

	 any other class has changed (but not its organization, since

	 that is cought in the above case).

	 We are not interrested in it - except, if showing fullProtocol

	 or hierarchy ...

	"

	currentClassHierarchy notNil ifTrue:[

	    fullProtocol ifTrue:[

		(currentClass isSubclassOf:changedObject) ifTrue:[

		]

	    ] ifFalse:[

		((currentClass isSubclassOf:changedObject)

		or:[changedObject isSubclassOf:currentClass]) ifTrue:[

		]                

	    ]

	].

	^ self

    ].

    (changedObject isMethod) ifTrue:[

    ]

! !

!BrowserView methodsFor:'class category list menu'!

classCategoryMenu

    |labels selectors|

    currentClassCategory isNil ifTrue:[

	labels := #(

		    'spawn full class'

		    '-'

		    'update'

		    'find class ...'

		    'find method ...'

		    '-'

		    'new class category ...'

		   ).

	selectors := #(

		    classCategorySpawnFullClass

		    nil

		    classCategoryUpdate

		    classCategoryFindClass

		    classCategoryFindMethod

		    nil

		    classCategoryNewCategory

		   ).

    ] ifFalse:[

	labels := #(

		    'fileOut'

		    'fileOut each'

"

		    'fileOut binary'

"

		    'printOut' 

		    'printOut protocol'

		    '-'

		    'clone'

		    'SPAWN_CATEGORY'

		    'spawn full class'

		    '-'

		    'update'

		    'find class ...'

		    'find method ...'

		    '-'

		    'new class category ...'

		    'rename ...'

		    'remove'

		   ).

	selectors := #(

		   classCategoryFileOut

		   classCategoryFileOutEach

		   classCategoryPrintOut

		   classCategoryPrintOutProtocol

		   nil

		   classCategoryClone

		   classCategorySpawn

		   classCategorySpawnFullClass

		   nil

		   classCategoryUpdate

		   classCategoryFindClass

		   classCategoryFindMethod

		   nil

		   classCategoryNewCategory

		   classCategoryRename

		   classCategoryRemove

		   ).

    ].

    ^ PopUpMenu labels:(resources array:labels)

		selectors:selectors

    "Created: 14.9.1995 / 10:50:17 / claus"

!

classCategoryClone

    "create a new SystemBrowser showing the same method as I do"

    |newBrowser|

    newBrowser := SystemBrowser open.

    currentClass notNil ifTrue:[

	newBrowser waitUntilVisible.

	newBrowser switchToClassNamed:currentClass name. 

	newBrowser updateClassCategoryList.

	showInstance ifFalse:[

	    newBrowser instanceProtocol:false

	].

	newBrowser updateMethodCategoryList.

	currentSelector notNil ifTrue:[

	    newBrowser switchToMethodNamed:currentSelector.

	]

    ]

    "Created: 14.9.1995 / 10:55:20 / claus"

    "Modified: 14.9.1995 / 10:59:31 / claus"

!

classCategoryUpdate

    "update class category list and dependants"

    |oldClassName oldMethodCategory|

    classCategoryListView notNil ifTrue:[

	currentClass notNil ifTrue:[

	    oldClassName := currentClass name.

	    (oldClassName endsWith:'-old') ifTrue:[

		oldClassName := oldClassName copyWithoutLast:4 "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

		]

	    ]

	]

    ]

!

classCategoryPrintOutProtocol

    |printStream|

    Smalltalk allClassesInCategory:currentClassCategory inOrderDo:[:aClass |

	printStream := Printer new.

	aClass printOutProtocolOn:printStream.

	printStream close

    ]

!

classCategoryPrintOut

    |printStream|

    Smalltalk allClassesInCategory:currentClassCategory do:[:aClass |

	printStream := Printer new.

	aClass printOutOn:printStream.

	printStream close

    ]

!

classCategorySpawn

    "create a new SystemBrowser browsing current classCategory"

    currentClassCategory notNil ifTrue:[

	self withWaitCursorDo:[

	    SystemBrowser browseClassCategory:currentClassCategory

	]

    ]

!

classCategoryFileOut

    "create a file 'categoryName' consisting of all classes in current category"

    |aStream fileName|

    self checkClassCategorySelected ifFalse:[^ self].

    fileName := currentClassCategory asString.

    fileName replaceAll:Character space by:$_.

    "

     this test allows a smalltalk to be built without Projects/ChangeSets

    "

    Project notNil ifTrue:[

	fileName := Project currentProjectDirectory , fileName.

    ].

    self withWaitCursorDo:[

	"

	 if file exists, save original in a .sav file

	"

	fileName asFilename exists ifTrue:[

	    self busyLabel:'saving existing %1' with:fileName.

	    fileName asFilename copyTo:(fileName , '.sav')

	].

	aStream := FileStream newFileNamed:fileName.

	aStream isNil ifTrue:[

	    self warn:'cannot create: %1' with:fileName

	] ifFalse:[

	    self busyLabel:'writing: %1' with:fileName.

	    Smalltalk allClassesInCategory:currentClassCategory inOrderDo:[:aClass |

		aClass fileOutOn:aStream.

	    ].

	    aStream close.

	]

    ].

    self normalLabel.

!

classCategorySpawnFullClass

    "create a new SystemBrowser browsing full class"

    |newBrowser|

    self withWaitCursorDo:[

	newBrowser := SystemBrowser browseFullClasses

" "

	.

	currentClass notNil ifTrue:[

	    newBrowser switchToClassNamed:(currentClass name)

	]

" "

    ]

!

classCategoryFileOutEach

    self withWaitCursorDo:[

	Smalltalk allClassesInCategory:currentClassCategory do:[:aClass |

	    self busyLabel:'saving: %1' with:aClass name.

	    Class fileOutErrorSignal handle:[:ex |

		self warn:'cannot create: %1' with:ex parameter.

		ex return.

	    ] do:[

		aClass fileOut

	    ]

	].

	self normalLabel.

    ]

!

classCategoryNewCategory

    |box|

    box := self enterBoxTitle:'name of new class category:' okText:'create'.

    box action:[:aString |

	|categories|

	currentClass notNil ifTrue:[

	    categories := Set new.

	    currentClass withAllSuperclasses do:[:aClass |

		aClass methodArray do:[:aMethod |

		    categories add:aMethod category