Fix issue #18598: Duplicating a class fails to log methods in Epicea

src/Epicea-Tests/EpCodeChangeIntegrationTest.class.st

@@ -202,6 +202,21 @@ EpCodeChangeIntegrationTest >> testMethodAddition [
 	self assert: (self countLogEventsWith: EpMethodAddition) equals: 1
 ]
 
+{ #category : 'tests' }
+EpCodeChangeIntegrationTest >> testMethodAdditionFromExistingClass [
+
+	| anotherClass |
+	aClass := classFactory newClass.
+	aClass compile: 'fortyTwo ^42'.
+
+	self assert: (self countLogEventsWith: EpMethodAddition) equals: 1.
+
+	anotherClass := classFactory newClass.
+	anotherClass compileAllFrom: aClass.
+
+	self assert: (self countLogEventsWith: EpMethodAddition) equals: 2
+]
+
 { #category : 'tests' }
 EpCodeChangeIntegrationTest >> testMethodModificationOfProtocol [
 

src/Kernel-Tests/ClassAnnouncementsTest.class.st

@@ -6,6 +6,21 @@ Class {
 	#tag : 'Classes'
 }
 
+{ #category : 'tests' }
+ClassAnnouncementsTest >> testDuplicatingAClassAnnouncesAddition [
+
+	class compile: 'billy ^ #meow' classified: '*' , self packageNameForTests , '2'.
+
+	self when: ClassAdded do: [ :ann |
+		self assert: ann classAffected originalName equals: self classNameForTests, '2'.
+		self assert: ann packageAffected name equals: self packageNameForTests.
+		self assertCollection: (ann packagesAffected collect: [ :package | package name ]) hasSameElements: { self packageNameForTests } ].
+
+	class duplicateClassWithNewName: self classNameForTests, '2'.
+
+	self assert: numberOfAnnouncements equals: 1
+]
+
 { #category : 'tests' }
 ClassAnnouncementsTest >> testRemovingAClassWithExtension [
 	"Regression test about an issue where class removed was not returning the extension packages in its affected packages"

src/Kernel-Tests/MethodAnnouncementsTest.class.st

@@ -26,6 +26,25 @@ MethodAnnouncementsTest >> testCompileMethodAnnounceAddition [
 	self assert: numberOfAnnouncements equals: 1
 ]
 
+{ #category : 'tests' }
+MethodAnnouncementsTest >> testCompileMethodByDuplicatingAClassAnnounceAddition [
+
+	class compiler
+		protocol: #titan;
+		install: 'king ^ 1'.
+
+	self when: MethodAdded do: [ :ann |
+		self assert: ann method selector equals: #king.
+		self assert: ann method protocol name equals: #titan.
+		self assert: ann methodClass name equals: self classNameForTests, '2'.
+		self assert: ann methodPackage name equals: self packageNameForTests.
+		self assert: ann packagesAffected equals: { self packageNameForTests asPackage } ].
+
+	class duplicateClassWithNewName: self classNameForTests, '2'.
+
+	self assert: numberOfAnnouncements equals: 1
+]
+
 { #category : 'tests' }
 MethodAnnouncementsTest >> testRemoveMethodAnnounceRemoval [
 

src/OpalCompiler-Core/Behavior.extension.st

@@ -15,6 +15,26 @@ Behavior >> compile: code [
 	^self compile: code notifying: nil
 ]
 
+{ #category : '*OpalCompiler-Core' }
+Behavior >> compile: selector from: oldClass [ 
+	"Compile the method associated with selector in the receiver's method dictionary."
+
+	| method newMethod |
+	method := oldClass compiledMethodAt: selector.
+	newMethod := oldClass compiler
+		             source: (oldClass sourceCodeAt: selector);
+		             priorMethod: method;
+		             class: self;
+		             permitFaulty: true;
+		             "No need to log recompilation in the sources,
+					 	 We are going to reuse the original source pointer."
+		             logged: false;
+		             install.
+	newMethod sourcePointer: method sourcePointer.
+	selector == newMethod selector ifFalse: [
+		self error: 'selector changed!' ]
+]
+
 { #category : '*OpalCompiler-Core' }
 Behavior >> compile: code notifying: requestor [
 	"Compile the argument, code, as source code in the context of the
@@ -46,7 +66,7 @@ Behavior >> compileAllFrom: oldClass [
 	"Compile all the methods in the receiver's method dictionary.
 	This validates sourceCode and variable references and forces
 	all methods to use the current bytecode set"
-	oldClass localSelectors do: [:sel | self recompile: sel from: oldClass]
+	oldClass localSelectors do: [:sel | self compile: sel from: oldClass]
 ]
 
 { #category : '*OpalCompiler-Core' }
@@ -83,24 +103,8 @@ Behavior >> recompile: selector [
 
 { #category : '*OpalCompiler-Core' }
 Behavior >> recompile: selector from: oldClass [
-	"Compile the method associated with selector in the receiver's method dictionary."
-
-	| method newMethod |
 
 	"Recompilation should be done silently, to avoid putting noise in the system"
 	self codeChangeAnnouncer suspendAllWhile: [
-		method := oldClass compiledMethodAt: selector.
-		newMethod := oldClass compiler
-			             source: (oldClass sourceCodeAt: selector);
-			             priorMethod: method;
-			             class: self;
-			             permitFaulty: true;
-			             "No need to log recompilation in the sources,
-						 	 We are going to reuse the original source pointer."
-			             logged: false;
-			             install ].
-
-	newMethod sourcePointer: method sourcePointer.
-	selector == newMethod selector ifFalse: [
-		self error: 'selector changed!' ]
+		self compile: selector from: oldClass ].
 ]

src/Shift-ClassBuilder/ShiftClassBuilder.class.st

@@ -56,7 +56,8 @@ Class {
 		'superclassResolver',
 		'inRemake',
 		'package',
-		'tag'
+		'tag',
+		'movedToPackage'
 	],
 	#classVars : [
 		'BuilderEnhancer'
@@ -118,15 +119,19 @@ ShiftClassBuilder >> build [
 	self createClass.
 
 	self oldClass ifNotNil: [
+		self copyPackage.
 		self copyProtocols.
 		self newClass commentSourcePointer: self oldClass commentSourcePointer ].
 
 	self createSharedVariables.
 
 	self installSlotsAndVariables.
 
-	self oldClass ifNotNil: [ self builderEnhancer compileMethodsFor: self ].
-
+	self oldClass ifNotNil: [ 
+		self builderEnhancer compileMethodsFor: self.
+		self environment codeChangeAnnouncer  announce: (ClassAdded class: newClass).
+
+		 ].
 	self builderEnhancer afterMethodsCompiled: self.
 	^ newClass
 ]
@@ -222,6 +227,34 @@ ShiftClassBuilder >> compileMethods [
 		removeNonexistentSelectorsFromProtocols
 ]
 
+{ #category : 'building' }
+ShiftClassBuilder >> copyPackage [
+
+	| oldPackage oldTag |
+
+	self isRebuild ifTrue: [
+		oldPackage := oldClass package name.
+		oldTag := oldClass packageTag name.
+
+		{ oldClass instanceSide . oldClass classSide } 
+			do: [:cls | cls package removeClass: cls ] .
+
+		self package ifNil: [ 
+			self environment codeChangeAnnouncer suspendAllWhile: [
+				newClass package: oldPackage tag: oldTag.
+				movedToPackage := true
+			]
+		]
+	].
+	self movedToPackage ifFalse: [ 
+		self environment codeChangeAnnouncer suspendAllWhile: [
+			newClass package: self package tag: self tag.
+			movedToPackage := true
+		].
+	]
+
+]
+
 { #category : 'building' }
 ShiftClassBuilder >> copyProtocols [
 
@@ -482,6 +515,11 @@ ShiftClassBuilder >> metaclassClass [
 	^ self builderEnhancer metaclassClassFor: self
 ]
 
+{ #category : 'accessing' }
+ShiftClassBuilder >> movedToPackage [
+	^ movedToPackage ifNil: [ movedToPackage := false ]
+]
+
 { #category : 'accessing' }
 ShiftClassBuilder >> name [
 	^ name

src/Shift-ClassBuilder/ShiftClassInstaller.class.st

@@ -170,8 +170,8 @@ ShiftClassInstaller >> installingEnvironment: anEnvironment [
 
 { #category : 'building' }
 ShiftClassInstaller >> make [
-	| newClass |
 
+	| newClass |
 	[
 		newClass := builder build.
 
@@ -185,14 +185,14 @@ ShiftClassInstaller >> make [
 
 		builder builderEnhancer afterMigratingClass: builder installer: self.
 
-		builder builderEnhancer propagateChangesToRelatedClasses: newClass builder: builder.
+		builder builderEnhancer propagateChangesToRelatedClasses: newClass builder: builder 
 
-	] on: ShNoChangesInClass do:[
+	] on: ShNoChangesInClass do: [ 
 		"If there are no changes in the building, I am not building or replacing nothing"
-		newClass := self oldClass.
+		newClass := self oldClass 
 	].
 
-	self updatePackage: newClass.
+	builder movedToPackage ifFalse: [ self updatePackage: newClass ].
 	self comment: newClass.
 
 	self notifyChanges.