hg/stx-libtool: comparison BrowserView.st

equal deleted inserted replaced

-:17bc3051f5d7
+:4943d5582937
 ].
 ^ i
 "Modified: 19.3.1997 / 20:48:34 / ca"
 "Modified: 15.8.1997 / 15:29:16 / cg"
+!
+fileImageIcon
+"answer an icon to mark file-loading image  methods"
+^ self imageIcon
+"Created: / 29.10.1997 / 03:32:43 / cg"
 !
 imageIcon
 "answer an icon to mark image (menuSpec) methods"
 "Created: 23.12.1996 / 12:45:43 / cg"
 "Modified: 16.1.1997 / 01:46:39 / cg"
 !
+classDoubleClick:lineNr
+currentClass notNil ifTrue:[
+currentClass isVisualStartable ifTrue:[
+currentClass open
+]
+]
+"Modified: / 28.10.1997 / 12:45:05 / cg"
+"Created: / 29.10.1997 / 15:50:26 / cg"
+!
 classListUpdate
 RememberAspect ifTrue:[
 	aspect == #hierarchy ifTrue:[
 	    ^ self classHierarchy
 	].
 ].
 v := classListView.
 v notNil ifTrue:[
 v action:[:lineNr | self classSelection:lineNr].
+v doubleClickAction:[:lineNr | self classDoubleClick:lineNr].
 v selectConditionBlock:checkBlock.
 v ignoreReselect:false.
 "
 tell classListView to ask for the menu
 "
 fullProtocol ifTrue:[
 classListView scrollToBottom.
 ]
 "Created: / 24.7.1997 / 18:14:59 / cg"
-"Modified: / 27.10.1997 / 00:29:30 / cg"
+"Modified: / 29.10.1997 / 15:50:26 / cg"
 !
 terminate
 (self checkSelectionChangeAllowed) ifTrue:[
 	super terminate
 self checkMethodSelected ifFalse:[^ self].
 w := currentMethod who.
 w notNil ifTrue:[
-	cls := w methodClass.
+cls := w methodClass.
-	cls notNil ifTrue:[
+cls notNil ifTrue:[
-	    cls ~~ actualClass ifTrue:[
+cls ~~ actualClass ifTrue:[
-		^ self warn:'oops - obsolete class; please reselect class ...'
+^ self warn:'oops - obsolete class; please reselect class ...'
-	    ].
+].
-	    cls isMeta ifTrue:[
+cls isMeta ifTrue:[
-		cls := cls soleInstance
+cls := cls soleInstance
-	    ] ifFalse:[
+] ifFalse:[
-		cls := nil
+cls := nil
-	    ].
+].
-	    cls notNil ifTrue:[
+cls notNil ifTrue:[
-		sel := w methodSelector.
+sel := w methodSelector.
-		sel notNil ifTrue:[
+sel notNil ifTrue:[
-		    actualClass perform:sel.
+currentClass perform:sel.
-		    ^ self
+^ self
-		]
+]
-	    ]
+]
-	].
+].
 ].
 self warn:'cannot invoke method (no class)'
-"Modified: 29.4.1997 / 11:24:30 / dq"
+"Modified: / 29.4.1997 / 11:24:30 / dq"
+"Modified: / 29.10.1997 / 15:50:28 / cg"
 !
 methodLocalSuperSends
 "launch a browser showing super sends in current class & subclasses"
 icn := self menuIcon
 ] ifFalse:[
 (resources includesKey:#image) ifTrue:[
 icn := self imageIcon
 ] ifFalse:[
-(resources includesKey:#programMenu) ifTrue:[
+(resources includesKey:#fileImage) ifTrue:[
-icn := self programMenuIcon
+icn := self fileImageIcon
+] ifFalse:[
+(resources includesKey:#programMenu) ifTrue:[
+icn := self programMenuIcon
+]
 ]
 ]
 ]
 ]
 ].
 ^ LabelAndIcon icon:icn string:s
 ].
 ^ s
 "Created: / 22.10.1996 / 19:51:00 / cg"
-"Modified: / 28.10.1997 / 13:39:38 / cg"
+"Modified: / 29.10.1997 / 03:31:41 / cg"
 !
 listOfAllMethodsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
 "answer a list of all methods in a given method category
 of the argument, aClass and its superclasses.
 ! !
 !BrowserView methodsFor:'namespace menu'!
 nameSpaceMenu
+<resource: #programMenu >
 |labels selectors|
 labels := #('new namespace').
 selectors := #(nameSpaceNewNameSpace).
 (currentNamespace notNil
 and:[currentNamespace ~~ Smalltalk
 and:[currentNamespace ~= '* all *']]) ifTrue:[
-	"/ is it all empty ?
+"/ is it all empty ?
-	currentNamespace allClasses isEmpty ifTrue:[
+currentNamespace allClasses isEmpty ifTrue:[
-	    labels := labels , #('-' 'remove').
+labels := labels , #('-' 'remove').
-	    selectors := selectors , #(nil nameSpaceRemove).
+selectors := selectors , #(nil nameSpaceRemove).
-	]
+]
 ].
 ^ PopUpMenu
-	labels:(resources array:labels)
+labels:(resources array:labels)
-	selectors:selectors
+selectors:selectors
-	receiver:self.
+receiver:self.
-"Created: 4.1.1997 / 23:51:38 / cg"
+"Created: / 4.1.1997 / 23:51:38 / cg"
-"Modified: 31.7.1997 / 22:40:33 / cg"
+"Modified: / 29.10.1997 / 03:39:12 / cg"
 !
 nameSpaceNewNameSpace
 "create a namespace-definition prototype in codeview"
 setAcceptAndExplainActionsForMethod
 "tell the codeView what to do on accept and explain"
 codeView acceptAction:[:theCode |
-	|cat cls rslt|
+|cat cls rslt|
-	fullProtocol ifTrue:[
+fullProtocol ifTrue:[
-	    cls := acceptClass
+cls := acceptClass
-	].
+].
-	cls isNil ifTrue:[
+cls isNil ifTrue:[
-	    cls := actualClass
+cls := actualClass.
-	].
+cls isNil ifTrue:[
-	cls isNil ifTrue:[
+self warning:'oops class is gone; reselect and try again'.
-	    self warning:'oops class is gone; reselect and try again'.
+^ self
-	    ^ self
+].
-	].
+].
-	codeView cursor:Cursor execute.
+codeView cursor:Cursor execute.
-	(cat := currentMethodCategory) = '* all *' ifTrue:[
+(cat := currentMethodCategory) = '* all *' ifTrue:[
-	    "must check from which category this code came from ...
+"must check from which category this code came from ...
-	     ... thanks to Arno for pointing this out"
+... thanks to Arno for pointing this out"
-	    cat := self askForMethodCategory.
+cat := self askForMethodCategory.
-	].
+].
-	(cat notNil and:[cat notEmpty]) ifTrue:[
+(cat notNil and:[cat notEmpty]) ifTrue:[
-	    Object abortSignal catch:[
+Object abortSignal catch:[
-		lockUpdates := true.
+lockUpdates := true.
-		rslt := actualClass compilerClass
+Class methodRedefinitionSignal handle:[:ex |
-		    compile:theCode asString
+|answer oldVsNew oldPkg newPkg|
-		    forClass:cls
-		    inCategory:cat
+oldVsNew := ex parameter.
-		    notifying:codeView.
+oldPkg := oldVsNew key package.
+newPkg := oldVsNew value package.
-		codeView modified:false.
+answer := OptionBox
-		currentMethod := actualClass compiledMethodAt:currentSelector.
+request:
-		self updateMethodListWithScroll:false keepSelection:(rslt == currentMethod).
+('You are about to change code from another (system-) package.
-		self normalLabel.
+The methods original packageID was ''%1''.
-	    ].
+If you proceed, the new code will be marked as belonging
-	    lockUpdates := false.
+to the ''%2'' package (and this warning will not be shown again).
-	].
+If you proceed with ''keep'', the old packageID will be preserved.
-	codeView cursor:Cursor normal.
+Otherwise, hit ''cancel'' to leave the code unchanged.
+PS: you can disable these checks in the launchers settings-compilation dialog.' bindWith:oldPkg with:newPkg)
+label:'Method redefinition'
+form:(WarningBox iconBitmap)
+buttonLabels:#('cancel' 'keep' 'continue')
+values:#(#cancel #keep #continue)
+default:#continue.
+(answer ~~ #cancel) ifTrue:[
+ex proceedWith:answer
+]
+] do:[
+rslt := actualClass compilerClass
+compile:theCode asString
+forClass:cls
+inCategory:cat
+notifying:codeView.
+codeView modified:false.
+currentMethod := actualClass compiledMethodAt:currentSelector.
+self updateMethodListWithScroll:false keepSelection:(rslt == currentMethod).
+self normalLabel.
+]
+].
+lockUpdates := false.
+].
+codeView cursor:Cursor normal.
 ].
 codeView explainAction:[:theCode :theSelection |
-	self showExplanation:(Explainer
+self showExplanation:(Explainer
-				explain:theSelection
+explain:theSelection
-				in:theCode
+in:theCode
-				forClass:actualClass)
+forClass:actualClass)
 ].
-"Modified: 19.6.1997 / 18:57:35 / cg"
+"Modified: / 29.10.1997 / 15:48:35 / cg"
 !
 setDoitActionForClass
 "tell the codeView what to do on doIt"
 commentEmphasis
 ^ (#color -> (Color red:0 green:0 blue:25))
 "Created: 1.8.1997 / 12:36:14 / cg"
+!
+fileImageIcon
+"answer an icon to mark fileImage methods"
+^ self class fileImageIcon
+"Modified: / 7.4.1997 / 17:31:40 / cg"
+"Created: / 29.10.1997 / 03:32:05 / cg"
 !
 imageIcon
 "answer an icon to mark image methods"
 ! !
 !BrowserView class methodsFor:'documentation'!
 version
-^ '$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.345 1997-10-28 18:26:12 cg Exp $'
+^ '$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.346 1997-10-29 16:02:53 cg Exp $'
 ! !
 BrowserView initialize!

changeset 1360	4943d5582937
parent 1355	34c98fc48b14
child 1362	df021eafd510