SystemOrganization addCategory: #'Slime-Core'! !ParseTreeEnvironment methodsFor: '*slime' stamp: 'lr 12/17/2007 10:48'! matcher ^ matcher ifNil: [ matcher := ParseTreeSearcher new ]! ! Object subclass: #Slime instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Slime-Core'! Slime class instanceVariableNames: 'braceSelectors notPortableSelectors deprecatedSelectors superSelectors notPortableClasses brushSelectors callAnswerSelectors callbackSelectors attributeSelectors'! Slime class instanceVariableNames: 'braceSelectors notPortableSelectors deprecatedSelectors superSelectors notPortableClasses brushSelectors callAnswerSelectors callbackSelectors attributeSelectors'! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 23:35'! attributeSelectors ^ attributeSelectors! ! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 21:42'! braceSelectors ^ braceSelectors! ! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 23:21'! brushSelectors ^ brushSelectors! ! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 23:21'! callAnswerSelectors ^ callAnswerSelectors! ! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 23:21'! callbackSelectors ^ callbackSelectors! ! !Slime class methodsFor: 'accessing' stamp: 'lr 12/17/2007 23:04'! deprecatedSelectors ^ deprecatedSelectors! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/26/2008 09:51'! initialize self initializeAttributeSelectors. self initializeBrushSelectors. self initializeCallbackSelectors. self initializeCallAnswerSelectors. self initializeNotPortableSelectors. self initializeNotPortableClasses. self initializeDeprecatedSelectors. self initializeBraceSelectors. self initializeSuperSelectors! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 23:49'! initializeAttributeSelectors | matcher | matcher := ParseTreeSearcher new. matcher matchesAnyOf: #( 'self addClass: `@value' 'self addStyle: `@value' 'self attributeAt: `@key put: `@value' 'self attributeAt: `@key ifAbsentPut: `@block' 'self attributes at: `@key put: `@value' 'self attributes at: `@key ifAbsentPut: `@block' 'self attributes at: `@key append: `@value' 'self attributes at: `@key append: `@value separator: `@separator' ) do: [ :context :node | true ]. attributeSelectors := Set new. WABrush allSubclassesDo: [ :class | class methodDictionary keysAndValuesDo: [ :selector :method | (matcher executeTree: method parseTree initialAnswer: false) ifTrue: [ attributeSelectors add: selector ] ] ]. #( callback: enabled: labels: value: ) do: [ :each | attributeSelectors add: each ]! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 21:42'! initializeBraceSelectors braceSelectors := #( braceStream: braceWith: braceWith:with: braceWith:with:with: braceWith:with:with:with: braceWithNone ) asSet! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 23:22'! initializeBrushSelectors | matcher | matcher := ParseTreeSearcher new. matcher matchesAnyMethodOf: #( '`selector ^ self tag: `#tag' '`selector ^ self brush: `@obj' '`selector: `aBlock self `selector with: `aBlock' '`selector ^ `class on: self' ) do: [ :context :node | true ]. brushSelectors := Set new. WACanvas allSubclassesDo: [ :class | class methodDictionary keysAndValuesDo: [ :selector :method | (matcher executeTree: method parseTree initialAnswer: false) ifTrue: [ brushSelectors add: selector ] ] ]! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 23:41'! initializeCallAnswerSelectors callAnswerSelectors := #( answer answer: call: show: show:onAnswer: show:onAnswer:delegation: lightbox: chooseFrom: chooseFrom:caption: confirm: inform: request: request:default: request:label: request:label:default: ) asSet! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 23:38'! initializeCallbackSelectors callbackSelectors := #( callback: callback:value: defaultAction: triggerArgument:callback: triggerAutocompleter: triggerInPlaceEditor: triggerPassenger: triggerSliderCallback: triggerSortable:callback: triggerTree:callback: ) asSet! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 21:53'! initializeDeprecatedSelectors | selectors | selectors := #( deprecatedApi deprecatedApi: ). deprecatedSelectors := Set new. Object allSubclassesDo: [ :class | class methodDictionary keysAndValuesDo: [ :selector :method | method literalsDo: [ :each | (selectors includes: each) ifTrue: [ deprecatedSelectors add: selector ] ] ] ]. #( new text: renderDeprecatedOn: ) do: [ :each | deprecatedSelectors remove: each ifAbsent: [ ] ]! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 21:15'! initializeNotPortableClasses notPortableClasses := #( Semaphore MIMEDocument Random ) asSet! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 21:53'! initializeNotPortableSelectors notPortableSelectors := #( collect:thenDo: collect:thenSelect: fixTemps match: pairsDo: reject:thenDo: select:thenCollect: select:thenDo: signal signal: with:collect: ) asSet! ! !Slime class methodsFor: 'initialization' stamp: 'lr 1/25/2008 23:39'! initializeSuperSelectors superSelectors := Dictionary new. superSelectors at: WAComponent name put: #( initialize updateRoot: updateStates: updateUrl: initialRequest: ) asSet; at: WATagBrush name put: #( initialize setParent:canvas: #with: ) asSet! ! !Slime class methodsFor: 'testing' stamp: 'lr 1/25/2008 23:35'! isBrushSelector: aString Symbol hasInterned: aString ifTrue: [:symbol | ^ brushSelectors includes: symbol]. ^ false! ! !Slime class methodsFor: 'testing' stamp: 'lr 1/25/2008 23:21'! isCallbackSelector: aString Symbol hasInterned: aString ifTrue: [:symbol | ^ callbackSelectors includes: symbol]. ^ false! ! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 21:06'! nonportableSelectors ^ nonportableSelectors! ! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 21:14'! notPortableClasses. ^ notPortableClasses! ! !Slime class methodsFor: 'accessing' stamp: 'lr 1/25/2008 21:08'! notPortableSelectors ^ notPortableSelectors! ! !Slime class methodsFor: 'accessing' stamp: 'lr 12/17/2007 15:57'! superSelectors ^ superSelectors! ! !BlockLintRule class methodsFor: '*slime-portability' stamp: 'lr 1/26/2008 09:56'! basicNewInitializeMissing | matcher | matcher := ParseTreeSearcher new. matcher matchesMethod: 'new `@.stmts. ^ self basicNew initialize' do: [ :node :answer | true ]. ^ self new name: '#basicNew initialize is missing'; rationale: '#initialize is not called automatically when sending #new to an object in other Smalltalk dialects.'; classBlock: [ :context :result | (context selectedClass superclass = Object and: [ (context selectedClass includesSelector: #initialize) and: [ context selectedClass class methodDict noneSatisfy: [ :each | matcher executeTree: each parseTree initialAnswer: false ] ] ]) ifTrue: [ result addClass: context selectedClass selector: #initialize. result addClass: context selectedClass class selector: #new ] ]! ! !BlockLintRule class methodsFor: '*slime-bugs' stamp: 'lr 1/25/2008 23:19'! callAnswerWhileRendering | matcher matches | matcher := ParseTreeSearcher new. matcher matchesAnyOf: (Slime callAnswerSelectors collect: [ :each | '`receiver' , (ParseTreeLintRule genericPatternForSelector: each) ]) do: [ :node :answer | (node parents noneSatisfy: [ :each | each isBlock and: [ each parent isMessage and: [ Slime isCallbackSelector: each parent selector ] ] ]) ifTrue: [ answer add: node ]. answer ]. ^ self new name: '#call:/#answer: while rendering'; rationale: '#call: and #answer: should only be used from callback code, not within the rendering code.'; methodBlock: [ :context :result | context isRenderingMethod ifTrue: [ matches := matcher executeTree: context parseTree initialAnswer: OrderedCollection new. matches do: [ :each | result addClass: context selectedClass selector: context selector. result addSearchString: each selector ] ] ]! ! !BlockLintRule class methodsFor: '*slime-possible bugs' stamp: 'lr 12/17/2007 13:25'! changesStateWhileRendering | matcher matches | matcher := ParseTreeSearcher new. matcher matches: '`var' do: [ :node :answer | (node isWrite and: [ node parents noneSatisfy: [ :each | each isBlock and: [ each parent isMessage and: [ Slime isCallbackSelector: each parent selector ] ] ] ]) ifTrue: [ answer add: node ]. answer ]. ^ self new name: 'Changes state while rendering'; rationale: 'Application state should not be changed in the rendering code, use a callback to define state.'; resultClass: ParseTreeEnvironment; methodBlock: [ :context :result | | vars | context isRenderingMethod ifTrue: [ matches := matcher executeTree: context parseTree initialAnswer: OrderedCollection new. matches isEmpty ifFalse: [ vars := context instVarNames. matches do: [ :each | (vars includes: each name) ifTrue: [ result addClass: context selectedClass selector: context selector. result matcher matches: each name , ' := ``@obj' do: [ :node :answer | answer isNil ifTrue: [ node ] ifFalse: [ answer ] ] ] ] ] ] ]! ! !BlockLintRule class methodsFor: '*slime-bugs' stamp: 'lr 1/25/2008 20:30'! doesNotSendSuperInitialize ^ self new name: 'Does not send super'; rationale: 'Always send super when overriding specific hook methods.'; methodBlock: [ :context :result | | class selectors | class := context selectedClass allSuperclasses detect: [ :each | Slime superSelectors includesKey: each name ] ifNone: [ Object ]. selectors := Slime superSelectors at: class name ifAbsent: [ #() ]. ((selectors includes: context selector) and: [ (context parseTree superMessages includes: context selector) not ]) ifTrue: [ result addClass: context selectedClass selector: context selector ] ]! ! !BlockLintRule class methodsFor: '*slime-bugs' stamp: 'lr 1/26/2008 00:09'! instantiatesComponentWhileRendering | matcher matches | matcher := ParseTreeSearcher new. matcher matches: '`receiver `@message: `@args' do: [ :node :answer | | class | (node receiver isVariable and: [ (class := Smalltalk classNamed: node receiver token name) notNil and: [ class includesBehavior: WAComponent ] ]) ifTrue: [ (node parents noneSatisfy: [ :each | each isBlock and: [ each parent isMessage and: [ Slime isCallbackSelector: each parent selector ] ] ]) ifTrue: [ answer add: node ] ]. answer ]. ^ self new name: 'Instantiates component while rendering'; rationale: 'Components should only be instanciated in initialization-code, callbacks or through lazy initialization.'; methodBlock: [ :context :result | context isRenderingMethod ifTrue: [ matches := matcher executeTree: context parseTree initialAnswer: OrderedCollection new. matches do: [ :each | result addClass: context selectedClass selector: context selector. result addSearchString: each receiver name ] ] ] ! ! !BlockLintRule class methodsFor: '*slime-possible bugs' stamp: 'lr 1/25/2008 20:50'! sendsDeprecatedMessage ^ self new name: 'Sends deprecated message'; rationale: 'Deprecated selectors will be removed with the next release of Seaside.'; methodBlock: [ :context :result | context messages do: [ :each | (Slime deprecatedSelectors includes: each) ifTrue: [ result addClass: context selectedClass selector: context selector. result addSearchString: each ] ] ]! ! !BlockLintRule class methodsFor: '*slime-portability' stamp: 'lr 1/25/2008 21:11'! sendsNotPortableMessage ^ self new name: 'Sends not portable message'; rationale: 'Some methods are not portable accross different Smalltalk dialects.'; methodBlock: [ :context :result | context messages do: [ :each | (Slime notPortableSelectors includes: each) ifTrue: [ result addClass: context selectedClass selector: context selector. result addSearchString: each ] ] ]! ! !BlockLintRule class methodsFor: '*slime-portability' stamp: 'lr 1/25/2008 21:55'! usesCurlyBraceArrays ^ self new name: 'Uses curly brace arrays'; rationale: 'Curly brace expressions are not portable accross different Smalltalk dialects.'; methodBlock: [ :context :result | context compiledMethod literals do: [ :each | (each isSymbol and: [ Slime braceSelectors includes: each ]) ifTrue: [ result addClass: context selectedClass selector: context selector. result addSearchString: '{' ] ] ]! ! !BlockLintRule class methodsFor: '*slime-portability' stamp: 'lr 1/25/2008 21:50'! usesLiteralByteArrays ^ self new name: 'Uses literal byte arrays'; rationale: 'Literal byte arrays are not portable accross different Smalltalk dialects.'; methodBlock: [ :context :result | context compiledMethod literals do: [ :each | (each isLiteral and: [ each isKindOf: ByteArray ]) ifTrue: [ result addClass: context selectedClass selector: context selector. result addSearchString: '#[' ] ] ]! ! !BlockLintRule class methodsFor: '*slime-portability' stamp: 'lr 1/25/2008 21:18'! usesNotPortableClass ^ self new name: 'Uses not portable class'; rationale: 'Some classes are not portable accross different Smalltalk dialects.'; methodBlock: [ :context :result | context compiledMethod literalsDo: [ :each | (each isVariableBinding and: [ Slime notPortableClasses includes: each key ]) ifTrue: [ result addClass: context selectedClass selector: context selector. result addSearchString: each key ] ] ]! ! !ParseTreeLintRule class methodsFor: '*slime-miscellaneous' stamp: 'lr 12/17/2007 22:53'! avoidUnnecessaryWith | matcher | matcher := ParseTreeSearcher new. matcher matches: '`html `msg with: ``@arg' do: [ :node :answer | (answer isNil and: [ node parent isCascade not and: [ (Slime isBrushSelector: node receiver selector) and: [ (Slime isBrushSelector: node receiver selector , ':') and: [ (Slime isBrushSelector: node methodNode selector) not ] ] ] ]) ifTrue: [ node ] ]. ^ self new name: 'Avoid unnecessary #with:'; rationale: 'Sending #with: is only required if attributes are specified too.'; matcher: matcher; yourself! ! !ParseTreeLintRule class methodsFor: '*slime-miscellaneous' stamp: 'lr 1/25/2008 23:19'! extractCallbackCodeToMethod | matcher | matcher := ParseTreeSearcher new. matcher matchesAnyOf: (Slime callbackSelectors collect: [ :each | '`html `msg' , (self genericPatternForSelector: each) ]) do: [ :node :answer | (answer isNil and: [ Slime isBrushSelector: node receiver selector ]) ifTrue: [ node arguments detect: [ :each | each isBlock and: [ each body statements size > 1 ] ] ifNone: [ nil ] ] ]. ^ self new name: 'Extract callback code to separate method'; rationale: 'For clarity rendering code and callback code should not be mixed, extract the contents of the callback block to a separate method.'; matcher: matcher; yourself! ! !ParseTreeLintRule class methodsFor: '*slime-possible bugs' stamp: 'lr 1/26/2008 00:06'! fixCallbackTempsMissing | saveSelectors matcher | saveSelectors := #( allSatisfy: anySatisfy: at:ifAbsent: at:ifAbsentPut: at:ifPresent: collect: count: critical: detect:ifNone: do: do:separatedBy: ensure: fixCallbackTemps fixTemps ifCurtailed: inject:into: noneSatisfy: on:do: reject: render: select: should: should:description: should:raise: should:raise:description: should:raise:whoseDescriptionDoesNotInclude:description: should:raise:whoseDescriptionIncludes:description: shouldnt: shouldnt:description: shouldnt:raise: shouldnt:raise:description: shouldnt:raise:whoseDescriptionDoesNotInclude:description: shouldnt:raise:whoseDescriptionIncludes:description: timesRepeat: use:during: with: ) asSet. matcher := ParseTreeSearcher new. matcher matches: '[ | `@temps | `@.statements ]' do: [ :node :answer | | found | found := false. (answer isNil and: [ node isInlined not and: [ node parent isMessage ] ]) ifTrue: [ ((saveSelectors includes: node parent selector) or: [ (Slime brushSelectors includes: node parent selector) or: [ (Slime attributeSelectors includes: node parent selector) or: [ (Slime callbackSelectors includes: node parent selector) ] ] ]) ifFalse: [ | dangerousNames | dangerousNames := Set new. node parent parents do: [ :parent | parent isBlock ifTrue: [ dangerousNames addAll: parent argumentNames ]. parent isSequence ifTrue: [ dangerousNames addAll: parent temporaryNames ] ]. (dangerousNames anySatisfy: [ :each | node references: each ]) ifTrue: [ found := true ] ] ]. found ifTrue: [ node ] ]. ^ self new name: '#fixCallbackTemps possibly missing'; rationale: 'I don''t feel like explaining that here.'; matcher: matcher; yourself! ! !ParseTreeLintRule class methodsFor: '*slime-miscellaneous' stamp: 'lr 12/17/2007 22:51'! unnecessaryBlockPassedToBrush | matcher | matcher := ParseTreeSearcher new. matcher matchesAnyOf: #( '`html `msg: [ ]' '`html `msg: [ `html text: ``@arg ]' '`html `msg: [ `html render: ``@arg ]' ) do: [ :node :answer | (answer isNil and: [ Slime isBrushSelector: node selector ]) ifTrue: [ node arguments first ] ]. matcher matchesAnyOf: #( '`html `msg with: [ ]' '`html `msg with: [ `html text: ``@arg ]' '`html `msg with: [ `html render: ``@arg ]' ) do: [ :node :answer | (answer isNil and: [ Slime isBrushSelector: node receiver selector ]) ifTrue: [ node arguments first ] ]. ^ self new name: 'Unnecessary block passed to brush'; rationale: 'Sending a block as argument to #with: is only needed when nesting brushes.'; matcher: matcher; yourself! ! !ParseTreeLintRule class methodsFor: '*slime-bugs' stamp: 'lr 12/17/2007 13:38'! withHasToBeLastMessageInCascade | matcher | matcher := ParseTreeSearcher new. matcher matches: '`html `msg with: ``@arg' do: [ :node :answer | (answer isNil and: [ node parent isCascade and: [ (node parent messages last = node) not and: [ (Slime isBrushSelector: node receiver selector) ] ] ]) ifTrue: [ node ] ]. ^ self new name: '#with: has to be last message in cascade'; rationale: 'Sending #with: triggers serialization of the brush attributes, any attribute being specified afterwards has no effect.'; matcher: matcher; yourself! ! !RBProgramNode methodsFor: '*slime' stamp: 'lr 12/17/2007 10:02'! parents ^ parent isNil ifTrue: [ OrderedCollection with: self ] ifFalse: [ parent parents addLast: self; yourself ]! ! !SmalllintContext methodsFor: '*slime' stamp: 'lr 12/17/2007 09:55'! isRenderingMethod (self selector numArgs > 0 and: [ self selector beginsWith: #render ]) ifFalse: [ ^ false ]. self compiledMethod literalsDo: [ :each | (each isSymbol and: [ Slime isBrushSelector: each ]) ifTrue: [ ^ true ] ]. ^ false! ! Slime initialize!