Use PostgreSQL lexical rules in the standard Duplication Browser

docs/mooseide-integration.md

@@ -22,3 +22,14 @@ fork-first v3 development work, not a published v3 release.
 
 GitHub CI loads these optional tests in the ready-made Moose image. The plain
 Pharo job continues to test Core without GUI dependencies.
+
+## SQL duplication analysis
+
+Choose **PostgreSQL** as the source cleaner in the standard Duplication Browser settings, or open it with the preset:
+
+```smalltalk
+FmxSQLReplicationCleaner openOn: (model entities select: [ :entity |
+    entity hasSourceAnchor and: [ entity sourceAnchor hasSourceText ] ]).
+```
+
+The cleaner preserves SQL literals, quoted identifiers and dollar-quoted bodies; removes line and nested block comments; and keeps original line numbers. Whitespace inside literals stays significant. It assumes PostgreSQL `standard_conforming_strings = on`; explicit `E` strings support escaped quotes. Unterminated lexical input raises an error instead of silently changing its meaning. Dollar-quoted bodies are compared verbatim, without recursively interpreting their language. This is lexical clone detection, not semantic SQL equivalence. Thresholds remain configurable in the standard browser.

src/FamixNGSQL-MooseIDE-Tests/FmxSQLReplicationCleanerTest.class.st

@@ -0,0 +1,60 @@
+Class {
+ #name : #FmxSQLReplicationCleanerTest,
+ #superclass : #TestCase,
+ #category : #'FamixNGSQL-MooseIDE-Tests'
+}
+{ #category : #tests }
+FmxSQLReplicationCleanerTest >> testCommentsAndTokenBoundaries [
+ self assert: (FmxSQLReplicationCleaner new cleanedTextLines:
+   '-- heading', String lf, 'SELECT/* a /* nested */ b */x -- end') asArray
+   equals: { 2 -> 'SELECT x' }
+]
+{ #category : #tests }
+FmxSQLReplicationCleanerTest >> testQuotesAndDollarBodiesAreVerbatim [
+ | text |
+ text := 'SELECT ''https://x -- /*  y */'', "a""--b", $tag$ /*  -- */ $tag$, ''it''''s  ok'''.
+ self assert: (FmxSQLReplicationCleaner new cleanedTextLines: text) first value equals: text.
+ self deny: (FmxSQLReplicationCleaner new cleanedTextLines: 'SELECT ''a b''')
+   equals: (FmxSQLReplicationCleaner new cleanedTextLines: 'SELECT ''ab''')
+]
+{ #category : #tests }
+FmxSQLReplicationCleanerTest >> testEscapedQuoteAndMultilineLiteral [
+ | text lines |
+ text := 'SELECT E''a\''--  b'', $$', String lf, '  -- body  ', String lf, '$$;', String lf,
+   '/* comment', String lf, '*/', String lf, 'SELECT 2'.
+ lines := FmxSQLReplicationCleaner new cleanedTextLines: text.
+ self assert: lines second equals: 2 -> '  -- body  '.
+ self assert: lines last equals: 6 -> 'SELECT 2'.
+ self assert: lines first value equals: 'SELECT E''a\''--  b'', $$'
+]
+{ #category : #tests }
+FmxSQLReplicationCleanerTest >> testRejectsUnterminatedLexemes [
+ { '/* missing'. 'SELECT ''missing'. 'SELECT $a$missing' } do: [ :text |
+   self should: [ FmxSQLReplicationCleaner new cleanedTextLines: text ] raise: Error ]
+]
+{ #category : #tests }
+FmxSQLReplicationCleanerTest >> testStandardDetectorOnSQLSourceAnchors [
+ | entities configuration manager |
+ entities := (1 to: 2) collect: [ :i | | owner query |
+   owner := FmxSQLView new name: 'view', i asString; source: 'SELECT 1', String lf, 'FROM items'; yourself.
+   query := FmxSQLSelectQuery new.
+   query sourceAnchor: (FmxSQLEntitySourceAnchor new entity: owner; start: 1; end: owner source size; yourself).
+   query ].
+ configuration := FamixRepConfiguration sourcesCleaner: FmxSQLReplicationCleaner new
+   minimumNumberOfReplicas: 2 ofLines: 2 ofCharacters: 1.
+ manager := FamixRepDetector new configuration: configuration; runOn: entities.
+ self assert: manager replicatedFragments notEmpty.
+ self assert: manager replicatedFragments anyOne replicas anyOne codeText equals: entities first sourceText
+]
+
+{ #category : #tests }
+FmxSQLReplicationCleanerTest >> testStandardBrowserUsesSQLCleaner [
+ | owner query browser |
+ owner := FmxSQLView new source: 'SELECT 1'; yourself.
+ query := FmxSQLSelectQuery new.
+ query sourceAnchor: (FmxSQLEntitySourceAnchor new entity: owner; start: 1; end: 8; yourself).
+ browser := FmxSQLReplicationCleaner openOn: { query }.
+ [ self assert: browser specModel currentConfiguration sourcesCleaner class equals: FmxSQLReplicationCleaner.
+   self assert: (MiDuplicationBrowserModel availableSourcesCleaners anySatisfy: [ :cleaner |
+     cleaner class = FmxSQLReplicationCleaner ]) ] ensure: [ browser window close ]
+]

src/FamixNGSQL-MooseIDE/FmxSQLReplicationCleaner.class.st

@@ -0,0 +1,123 @@
+"PostgreSQL lexical cleaner. Preserves quoted text and line positions; assumes standard_conforming_strings = on."
+Class {
+ #name : #FmxSQLReplicationCleaner,
+ #superclass : #FamixRepSourcesCleaner,
+ #instVars : [ 'source', 'index', 'output', 'state', 'depth', 'delimiter', 'escaped', 'pendingSpace', 'lineHasCode' ],
+ #category : #'FamixNGSQL-MooseIDE'
+}
+
+{ #category : #accessing }
+FmxSQLReplicationCleaner class >> description [
+ ^ 'PostgreSQL comments and quoting (standard_conforming_strings=on)'
+]
+
+{ #category : #printing }
+FmxSQLReplicationCleaner class >> displayStringOn: stream [
+ stream nextPutAll: 'PostgreSQL'
+]
+
+{ #category : #opening }
+FmxSQLReplicationCleaner class >> openOn: entities [
+ | browser configuration |
+ (entities notEmpty and: [ entities allSatisfy: [ :entity |
+   (entity isKindOf: FmxSQLEntity) and: [ entity hasSourceAnchor ] ] ])
+   ifFalse: [ self error: 'Select SQL entities with source anchors' ].
+ browser := MiDuplicationBrowser new.
+ browser followEntity: entities asMooseGroup.
+ configuration := browser specModel currentConfiguration.
+ configuration sourcesCleaner: self new.
+ browser specModel updateFromConfiguration: configuration.
+ browser open.
+ ^ browser
+]
+
+{ #category : #cleaning }
+FmxSQLReplicationCleaner >> cleanedTextLines: text [
+ | lines |
+ source := text.
+ index := 1.
+ output := String new writeStream.
+ state := #normal.
+ depth := 0.
+ pendingSpace := false.
+ lineHasCode := false.
+ [ index <= source size ] whileTrue: [ self scanNext ].
+ (#(normal lineComment) includes: state) ifFalse: [ self error: 'Unterminated SQL quoted text or comment' ].
+ lines := OrderedCollection new.
+ output contents lines doWithIndex: [ :line :lineNumber |
+   line ifNotEmpty: [ lines add: lineNumber -> line ] ].
+ ^ lines
+]
+
+{ #category : #private }
+FmxSQLReplicationCleaner >> matches: text [
+ ^ index + text size - 1 <= source size and: [
+   (source copyFrom: index to: index + text size - 1) = text ]
+]
+
+{ #category : #private }
+FmxSQLReplicationCleaner >> putCode: character [
+ (pendingSpace and: [ lineHasCode ]) ifTrue: [ output space ].
+ pendingSpace := false.
+ output nextPut: character.
+ lineHasCode := true
+]
+
+{ #category : #private }
+FmxSQLReplicationCleaner >> dollarDelimiter [
+ | end tag |
+ end := source indexOf: $$ startingAt: index + 1 ifAbsent: [ 0 ].
+ end = 0 ifTrue: [ ^ nil ].
+ tag := source copyFrom: index + 1 to: end - 1.
+ (tag notEmpty and: [ (tag first isLetter or: [ tag first = $_ ]) not
+   or: [ (tag allSatisfy: [ :c | c isAlphaNumeric or: [ c = $_ ] ]) not ] ]) ifTrue: [ ^ nil ].
+ (index > 1 and: [ (source at: index - 1) isAlphaNumeric or: [ (source at: index - 1) = $_ ] ]) ifTrue: [ ^ nil ].
+ ^ source copyFrom: index to: end
+]
+
+{ #category : #private }
+FmxSQLReplicationCleaner >> scanNext [
+ | c quote |
+ c := source at: index.
+ state = #dollar ifTrue: [
+   (self matches: delimiter)
+     ifTrue: [ output nextPutAll: delimiter. index := index + delimiter size. state := #normal ]
+     ifFalse: [ output nextPut: c. index := index + 1 ].
+   ^ self ].
+ state = #quoted ifTrue: [
+   output nextPut: c.
+   index := index + 1.
+   (escaped and: [ c = $\ and: [ index <= source size ] ]) ifTrue: [
+     output nextPut: (source at: index). index := index + 1. ^ self ].
+   c = delimiter ifTrue: [
+     (index <= source size and: [ (source at: index) = delimiter ])
+       ifTrue: [ output nextPut: delimiter. index := index + 1 ]
+       ifFalse: [ state := #normal ] ].
+   ^ self ].
+ (c = Character cr or: [ c = Character lf ]) ifTrue: [
+   output nextPut: c. pendingSpace := false. lineHasCode := false.
+   state = #lineComment ifTrue: [ state := #normal ].
+   index := index + 1. ^ self ].
+ state = #lineComment ifTrue: [ index := index + 1. ^ self ].
+ state = #blockComment ifTrue: [
+   (self matches: '/*') ifTrue: [ depth := depth + 1. index := index + 2. ^ self ].
+   (self matches: '*/') ifTrue: [ depth := depth - 1. index := index + 2.
+     depth = 0 ifTrue: [ state := #normal ]. ^ self ].
+   index := index + 1. ^ self ].
+ c isSeparator ifTrue: [ pendingSpace := true. index := index + 1. ^ self ].
+ (self matches: '--') ifTrue: [ state := #lineComment. index := index + 2. ^ self ].
+ (self matches: '/*') ifTrue: [ state := #blockComment. depth := 1.
+   pendingSpace := true. index := index + 2. ^ self ].
+ quote := c = $' or: [ c = $" ].
+ quote ifTrue: [
+   escaped := c = $' and: [ index > 1 and: [
+     (source at: index - 1) asLowercase = $e and: [ index = 2 or: [
+       ((source at: index - 2) isAlphaNumeric or: [ '_$' includes: (source at: index - 2) ]) not ] ] ] ].
+   delimiter := c. state := #quoted ].
+ (c = $$ and: [ (delimiter := self dollarDelimiter) notNil ]) ifTrue: [
+   self putCode: c.
+   output nextPutAll: delimiter allButFirst.
+   index := index + delimiter size. state := #dollar. ^ self ].
+ self putCode: c.
+ index := index + 1
+]