'From Squeak3.9alpha of ''2 November 2004'' [latest update: #6520] on 5 December 2004 at 10:21:29 pm'! "Change Set: isKindOfbyIsClass-asm Date: 6 July 2003 Author: Alejandro Magistrello - replaces all isKindOf: Morph, Behavior, Collection, String, Number, Stream, Text by isForm, isBehavior, isCollection, isString, isNumber, isStream, isText "! !Behavior methodsFor: 'printing' stamp: 'asm 7/6/2003 16:57'! literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key _ scannedLiteral key. value _ scannedLiteral value. key isNil ifTrue: "###" [(self bindingOf: value) ifNotNilDo:[:assoc| (assoc value isBehavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isSymbol) ifTrue: "##" [(self bindingOf: key) ifNotNilDo:[:assoc | ^assoc]. Undeclared at: key put: nil. ^Undeclared bindingOf: key]. requestor notify: '## must be followed by a non-local variable name'. ^false " Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "! ! !Browser methodsFor: 'class functions' stamp: 'tlk 1/30/2004 21:30'! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass _ self selectedClassOrMetaClass. defTokens _ defString findTokens: Character separators. keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category']. envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $'). keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x]. newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass _ oldClass superclass]. class _ oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. class isBehavior ifTrue: [self changed: #systemCategoryList. self changed: #classList. self clearUserEditFlag. self setClass: class selector: nil. "self clearUserEditFlag; editClass." ^ true] ifFalse: [^ false]! ! !Class methodsFor: 'fileIn/Out' stamp: 'asm 7/6/2003 16:59'! fileOutPool: aPool onFileStream: aFileStream | aPoolName aValue | (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. aPoolName _ self environment keyAtIdentityValue: aPool. Transcript cr; show: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asSortedCollection do: [ :aKey | aValue _ aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. aValue isNumber ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'asm 7/2/2003 23:44'! buildFakeSlider: nameStringOrSymbol selector: aSymbol help: helpString | col | col := self inAColumn: { nameStringOrSymbol isSymbol ifTrue: [(UpdatingStringMorph new) useStringFormat; getSelector: nameStringOrSymbol; target: self; growable: true; minimumWidth: 24; lock] ifFalse: [self lockedString: nameStringOrSymbol]}. col borderWidth: 2; borderColor: color darker; color: color muchLighter; hResizing: #shrinkWrap; setBalloonText: helpString; on: #mouseMove send: #mouseAdjust:in: to: self; on: #mouseDown send: #mouseAdjust:in: to: self; on: #mouseUp send: #clearSliderFeedback to: self; setProperty: #changeSelector toValue: aSymbol. ^col! ! !Inspector methodsFor: 'menu commands' stamp: 'tlk 12/5/2004 20:54'! copyName "Copy the name of the current variable, so the user can paste it into the window below and work with is. If collection, do (xxx at: 1)." | sel aClass variableNames | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. aClass _ self object class. variableNames _ aClass allInstVarNames. (aClass isVariable and: [selectionIndex > (variableNames size + 2)]) ifTrue: [sel _ '(self basicAt: ' , (selectionIndex - (variableNames size + 2)) asString , ')'] ifFalse: [sel _ variableNames at: selectionIndex - 2]. self selection isCollection ifTrue: [sel _ '(' , sel , ' at: 1)']. Clipboard clipboardText: sel asText! ! !PackageInfo methodsFor: 'dependencies' stamp: 'asm 7/3/2003 00:01'! externalCallers ^ self externalRefsSelect: [:literal | literal isSymbol] thenCollect: [:l | l].! ! !ParagraphEditor methodsFor: 'explain' stamp: 'asm 7/6/2003 17:00'! explainGlobal: symbol "Is symbol a global variable?" | reply classes | reply _ Smalltalk at: symbol ifAbsent: [^nil]. (reply class == Dictionary or:[reply isKindOf: SharedPool class]) ifTrue: [classes _ Set new. self systemNavigation allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes add: each]]. classes _ classes printString. ^'"is a global variable. It is a pool which is used by the following classes ' , (classes allButFirst: 5) , '"']. (reply isBehavior) ifTrue: [^'"is a global variable. ' , symbol , ' is a class in category ', reply category, '."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.']. symbol == #Smalltalk ifTrue: [^'"is a global. Smalltalk is the only instance of SystemDictionary and holds all global variables."']. ^'"is a global variable. ' , symbol , ' is ' , reply printString , '"'! ! !PhraseTileMorph methodsFor: 'initialization' stamp: 'asm 7/3/2003 00:05'! vocabulary: aVocab "Set the vocabulary" vocabularySymbol := (aVocab isSymbol) ifTrue: [aVocab] ifFalse: [aVocab vocabularyName]! ! !Player methodsFor: 'slots-user' stamp: 'asm 7/3/2003 00:07'! slotInfoAt: slotName | info | info := self slotInfo at: slotName ifAbsent: [nil]. info ifNil: [self slotInfo at: slotName put: (info := SlotInformation new initialize)]. info isSymbol ifTrue: ["bkward compat" self slotInfo at: slotName put: (info := SlotInformation new type: info)]. ^info! ! !PluggableListView methodsFor: 'updating' stamp: 'tlk 12/5/2004 21:01'! verifyContents | newItems existingSelection anIndex | "Called on window reactivation to react to possible structural changes. Update contents if necessary." newItems _ self getList. ((items == newItems) "fastest" or: [items = newItems]) ifTrue: [^ self]. self flash. "list has changed beneath us; could get annoying, but hell" existingSelection _ list stringAtLineNumber: (selection + (topDelimiter ifNil: [0] ifNotNil: [1])). "account for cursed ------ row" self list: newItems. (newItems size > 0 and: [newItems first isSymbol]) ifTrue: [existingSelection _ existingSelection asSymbol]. (anIndex _ newItems indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector.] ifNil: [self changeModelSelection: 0]. selection := 0. " to display the list without selection " self displayView. self update: getSelectionSelector. ! ! !PostscriptCanvas methodsFor: 'drawing support' stamp: 'asm 7/3/2003 00:11'! stroke: strokeColor strokeColor ifNil: [^self]. strokeColor isSymbol ifTrue: [^self paint: Color gray operation: #stroke "punt"]. strokeColor isSolidFill ifTrue: [^self paint: strokeColor asColor operation: #stroke]. self preserveStateDuring: [:inner | inner strokepath; fill: strokeColor]! ! !PseudoClass methodsFor: 'testing' stamp: 'asm 7/3/2003 00:14'! exists ^(Smalltalk at: self name asSymbol ifAbsent:[^false]) isBehavior! ! !Scanner methodsFor: 'expression types' stamp: 'asm 7/3/2003 00:16'! nextLiteral "Same as advance, but -4 comes back as a number instead of two tokens" | prevToken | prevToken _ self advance. (prevToken == #- and: [token isNumber]) ifTrue: [^self advance negated]. ^prevToken! ! !SequenceableCollection methodsFor: 'converting' stamp: 'asm 7/3/2003 00:17'! asStringWithCr "Convert to a string with returns between items. Elements are usually strings. Useful for labels for PopUpMenus." | labelStream | labelStream _ WriteStream on: (String new: 200). self do: [:each | each isString ifTrue: [labelStream nextPutAll: each; cr] ifFalse: [each printOn: labelStream. labelStream cr]]. self size > 0 ifTrue: [labelStream skip: -1]. ^ labelStream contents! ! !SequenceableCollection methodsFor: 'private' stamp: 'asm 7/3/2003 00:18'! copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens "Answer a copy of the receiver in which all occurrences of oldSubstring have been replaced by newSubstring. ifTokens (valid for Strings only) specifies that the characters surrounding the recplacement must not be alphanumeric. Bruce Simth, must be incremented by 1 and not newSubstring if ifTokens is true. See example below. " | aString startSearch currentIndex endIndex | (ifTokens and: [self isString not]) ifTrue: [self isText ifFalse: [ self error: 'Token replacement only valid for Strings']]. aString _ self. startSearch _ 1. [(currentIndex _ aString indexOfSubCollection: oldSubstring startingAt: startSearch) > 0] whileTrue: [endIndex _ currentIndex + oldSubstring size - 1. (ifTokens not or: [(currentIndex = 1 or: [(aString at: currentIndex-1) isAlphaNumeric not]) and: [endIndex = aString size or: [(aString at: endIndex+1) isAlphaNumeric not]]]) ifTrue: [aString _ aString copyReplaceFrom: currentIndex to: endIndex with: newSubstring. startSearch _ currentIndex + newSubstring size] ifFalse: [ ifTokens ifTrue: [startSearch _ currentIndex + 1] ifFalse: [startSearch _ currentIndex + newSubstring size]]]. ^ aString "Test case: 'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true " ! ! !SystemNavigation methodsFor: 'browse' stamp: 'asm 7/6/2003 17:13'! browseObsoleteReferences "self new browseObsoleteReferences" | references | references _ OrderedCollection new. (LookupKey allSubInstances select: [:x | ((x value isBehavior) and: ['AnOb*' match: x value name]) or: ['AnOb*' match: x value class name]]) do: [:x | references addAll: (self allCallsOn: x)]. self browseMessageList: references name: 'References to Obsolete Classes'! ! !TextURL methodsFor: 'as yet unclassified' stamp: 'tlk 1/31/2004 20:39'! actOnClickFor: anObject "Do what you can with this URL. Later a web browser." | response m | (url beginsWith: 'sqPr://') ifTrue: [ ProjectLoading thumbnailFromUrl: (url copyFrom: 8 to: url size). ^self "should not get here, but what the heck" ]. "if it's a web browser, tell it to jump" anObject isWebBrowser ifTrue: [anObject jumpToUrl: url. ^ true] ifFalse: [((anObject respondsTo: #model) and: [anObject model isWebBrowser]) ifTrue: [anObject model jumpToUrl: url. ^ true]]. "if it's a morph, see if it is contained in a web browser" anObject isMorph ifTrue: [ m _ anObject. [ m ~= nil ] whileTrue: [ (m isWebBrowser) ifTrue: [ m jumpToUrl: url. ^true ]. (m hasProperty: #webBrowserView) ifTrue: [ m model jumpToUrl: url. ^true ]. m _ m owner. ] ]. "no browser in sight. ask if we should start a new browser" ((self confirm: 'open a browser to view this URL?' translated) and: [WebBrowser default notNil]) ifTrue: [ WebBrowser default openOnUrl: url. ^ true ]. "couldn't display in a browser. Offer to put up just the source" response _ (PopUpMenu labels: 'View web page as source Cancel' translated) startUpWithCaption: 'Couldn''t find a web browser. View page as source?' translated. response = 1 ifTrue: [HTTPSocket httpShowPage: url]. ^ true! ! !TheWorldMenu methodsFor: 'construction' stamp: 'tlk 1/31/2004 21:17'! fillIn: aMenu from: dataForMenu "A menu constructor utility by RAA. dataForMenu is a list of items which mean: nil Indicates to add a line first element is symbol Add updating item with the symbol as the wording selector second element is a list second element has the receiver and selector first element is a string Add menu item with the string as its wording second element is a list second element has the receiver and selector a third element exists Use it as the balloon text a fourth element exists Use it as the enablement selector (updating case only)" | item | dataForMenu do: [ :itemData | itemData ifNil: [aMenu addLine] ifNotNil: [item _ (itemData first isSymbol) ifTrue: [aMenu addUpdating: itemData first target: self selector: #doMenuItem:with: argumentList: {itemData second}] ifFalse: [aMenu add: itemData first translated target: self selector: #doMenuItem:with: argumentList: {itemData second}]. itemData size >= 3 ifTrue: [aMenu balloonTextForLastItem: itemData third translated. itemData size >= 4 ifTrue: [item enablementSelector: itemData fourth]]]]. ^ aMenu! ! !TileMorph methodsFor: 'initialization' stamp: 'asm 7/3/2003 00:28'! rawVocabulary: aVocabulary "Set the receiver's vocabulary, without side effects." vocabularySymbol := (aVocabulary isSymbol) ifTrue: [aVocabulary] ifFalse: [aVocabulary vocabularyName]! ! !UpdatingStringMorph methodsFor: 'target access' stamp: 'asm 7/3/2003 00:29'! readFromTarget "Update my readout from my target" | v | (target isNil or: [getSelector isNil]) ifTrue: [^contents]. self checkTarget. v := target perform: getSelector. "scriptPerformer" (v isText) ifTrue: [v := v asString]. ^self acceptValueFromTarget: v! !