From 7e0424ff18fbb4b462ce2ac597e79b4669610f6b Mon Sep 17 00:00:00 2001 From: Dale Henrichs Date: Sun, 21 Jan 2024 09:43:19 -0800 Subject: [PATCH] Issue #913 and #909: eliminate some reCompileMethod variants that are unused outside of tests; move some more methods to Obsolete packages since they should be eilminated as part of #909 owrk --- .../Behavior.extension.st | 23 -- .../package.st | 0 .../RwPrjBrowserTool.extension.st | 275 ++++++++++++++++++ .../RwUnmanagedClassesV2Test.class.st | 18 +- .../RwProjectAuditToolTest.class.st | 180 ------------ .../RwPrjBrowserTool.class.st | 274 ----------------- 6 files changed, 284 insertions(+), 486 deletions(-) rename rowan/src/{Rowan-Obsolete-Gemstone => Rowan-Obsolete-GemStone}/Behavior.extension.st (76%) rename rowan/src/{Rowan-Obsolete-Gemstone => Rowan-Obsolete-GemStone}/package.st (100%) create mode 100644 rowan/src/Rowan-Obsolete/RwPrjBrowserTool.extension.st diff --git a/rowan/src/Rowan-Obsolete-Gemstone/Behavior.extension.st b/rowan/src/Rowan-Obsolete-GemStone/Behavior.extension.st similarity index 76% rename from rowan/src/Rowan-Obsolete-Gemstone/Behavior.extension.st rename to rowan/src/Rowan-Obsolete-GemStone/Behavior.extension.st index fd8357006..cc26d3d8a 100644 --- a/rowan/src/Rowan-Obsolete-Gemstone/Behavior.extension.st +++ b/rowan/src/Rowan-Obsolete-GemStone/Behavior.extension.st @@ -1,28 +1,5 @@ Extension { #name : 'Behavior' } -{ #category : '*rowan-obsolete-gemstone' } -Behavior >> rwCompileExtensionMethod: sourceString category: categoryName packageName: packageName [ - ^ Rowan projectTools browser - addOrUpdateMethod: sourceString - inProtocol: categoryName - forClassNamed: self thisClass name asString - isMeta: self isMeta - inPackageNamed: packageName -] - -{ #category : '*rowan-obsolete-gemstone' } -Behavior >> rwCompileExtensionMethod: sourceString package: aPackageName [ - - | aCategory | - aCategory := '*', aPackageName asLowercase . - ^Rowan projectTools browser - addOrUpdateMethod: sourceString - inProtocol: aCategory asString asLowercase - forClassNamed: self thisClass name asString - isMeta: self isMeta - -] - { #category : '*rowan-obsolete-gemstone' } Behavior >> rwCompileMethod: sourceString category: aCategoryString [ diff --git a/rowan/src/Rowan-Obsolete-Gemstone/package.st b/rowan/src/Rowan-Obsolete-GemStone/package.st similarity index 100% rename from rowan/src/Rowan-Obsolete-Gemstone/package.st rename to rowan/src/Rowan-Obsolete-GemStone/package.st diff --git a/rowan/src/Rowan-Obsolete/RwPrjBrowserTool.extension.st b/rowan/src/Rowan-Obsolete/RwPrjBrowserTool.extension.st new file mode 100644 index 000000000..b6279194a --- /dev/null +++ b/rowan/src/Rowan-Obsolete/RwPrjBrowserTool.extension.st @@ -0,0 +1,275 @@ +Extension { #name : 'RwPrjBrowserTool' } + +{ #category : '*rowan-obsolete' } +RwPrjBrowserTool >> addOrUpdateMethod: methodSource inProtocol: hybridPackageName forClassNamed: className isMeta: isMeta [ + "If the method is already installed in a different package, remove the method from that package. + If package name matches the name of the package of the class definition, then add the method + to the class definition. + If there is no matching class extension or the package name does not match, add the method + to a class extension in the named package. + Return the resulting compiled method" + + "a hybrid package name has a leading '*' followed by the name of a package ... + where the hybrid package name is not expected to preserve case" + + "this method is only needed for the transition from Oscar 3.x to Oscar 4.0 (Rowan V2 aware Jadeite" + + | methodDef loadedProject loadedPackage couldBeHybrid hybridLoadedPackage hybridLoadedProject loadedClass | + couldBeHybrid := (hybridPackageName at: 1) = $*. + couldBeHybrid + ifTrue: [ + hybridLoadedPackage := Rowan image + loadedHybridPackageNamed: hybridPackageName + ifAbsent: [ ]. + hybridLoadedPackage + ifNotNil: [ + | pkgConvention | + hybridLoadedProject := hybridLoadedPackage loadedProject. + pkgConvention := hybridLoadedProject packageConvention. + (pkgConvention = 'RowanHybrid' or: [ pkgConvention = 'Monticello' ]) + ifTrue: [ + | classPackageName "everything is cool" | + classPackageName := (Rowan image objectNamed: className) rowanPackageName. + classPackageName = hybridLoadedPackage name + ifTrue: [ + "https://github.com/GemTalk/Rowan/issues/802" + self + error: + 'extension category name ' , hybridPackageName printString + , ' must not match class package name (' , classPackageName , ')' ] ] + ifFalse: [ + "the project associated with the hybridPackageName _is NOT_ using the `RowanHybrid` package convention - questionable use of hybrid convention in a non-hybrid project" + Warning + signal: + 'The package convention for this project (' + , hybridLoadedProject name printString + , + ') is ''Rowan'' and a leading $* in the category is not used to denote a target package for any methods placed in this category'. + couldBeHybrid := false ] ] ]. + methodDef := RwMethodDefinition + newForSource: methodSource + protocol: hybridPackageName. + (self + _loadedMethod: methodDef selector + inClassNamed: className + isMeta: isMeta + ifAbsent: [ ]) + ifNil: [ + "new method extract project information from the class" + (Rowan image loadedClassNamed: className ifAbsent: [ ]) + ifNil: [ + "unpackaged class?" + couldBeHybrid + ifTrue: [ + hybridLoadedPackage + ifNil: [ + self + error: + 'A package for package name ' , hybridPackageName printString + , ' was not found.' ]. + hybridLoadedProject + ifNil: [ + self + error: + 'Attempt to add a method to an unpackaged class ' , className printString + , ', while using `hybrid-style` method protocol ' + , hybridPackageName printString + , + ' for a project that does not use the `RowanHybrid` package convention.' ]. + loadedPackage := hybridLoadedPackage. + loadedProject := hybridLoadedProject ] + ifFalse: [ + | theBehavior | + "Adding unpackaged method to an unpackaged class - if permitted" + theBehavior := Rowan image objectNamed: className. + isMeta + ifTrue: [ theBehavior := theBehavior class ]. + RwPerformingUnpackagedEditNotification + signal: + 'Attempt to add or modify an unpackage method in the class ' + , className printString + , '. The modification will not be tracked by Rowan'. + ^ theBehavior + compileMethod: methodSource + dictionaries: Rowan image symbolList + category: hybridPackageName + environmentId: 0 "Notification resumed, so continue with add/modify" ] ] + ifNotNil: [ :theLoadedClass | + loadedClass := theLoadedClass. + couldBeHybrid + ifTrue: [ + hybridLoadedPackage + ifNil: [ + self + error: + 'A package for package name ' , hybridPackageName printString + , ' was not found.' ]. + hybridLoadedProject + ifNil: [ + self + error: + 'Attempt to add a method to an unpackaged class ' , className printString + , ', while using `hybrid-style` method protocol ' + , hybridPackageName printString ]. + loadedPackage := hybridLoadedPackage. + loadedProject := hybridLoadedProject ] + ifFalse: [ + "new method for packaged class, so add method to the class' package" + loadedProject := theLoadedClass loadedProject. + loadedPackage := theLoadedClass loadedPackage ] ] ] + ifNotNil: [ :loadedMethod | + | isHybrid | + "change to existing loaded method - keep in mind that the method could be being moved between packages via protocol change" + loadedProject := loadedMethod loadedProject. + loadedClass := loadedMethod loadedClass. + isHybrid := loadedProject packageConvention = 'RowanHybrid'. + couldBeHybrid + ifTrue: [ + "protocol has leading *" + hybridLoadedPackage + ifNil: [ + "questionable use of hybrid protocol in a non-RowanHybrid project, but legal" + loadedPackage := loadedMethod loadedPackage ] + ifNotNil: [ + isHybrid + ifTrue: [ + "the current project for the method is using the `RowanHybrid` package convention" + hybridLoadedProject + ifNil: [ + "VERY questionable use of hybrid protocol, package matching the hyybrid protocol was found, but the project of the package is not using `RowanHybrid` package convention, while the current project _IS_ using hybrid protocol --- ILLEGAL" + self + error: + 'Attempt to use RowanHybrid convention ' , hybridPackageName printString + , ' for a package ' , hybridLoadedPackage name printString + , ' that belongs to a project ' + , hybridLoadedPackage loadedProject name printString + , ' that is not using `RowanHybrid` package convention.' ] + ifNotNil: [ + "moving from one hybrid package to another (or same) hybrid package" + loadedPackage := hybridLoadedPackage. + loadedProject := hybridLoadedProject ] ] + ifFalse: [ + "the current project is NOT using the `RowanHybrid` package convention" + hybridLoadedProject + ifNil: [ + "Questionable use of hybrid protocol, package matching the hyybrid protocol was found, but the project of the package is not using `RowanHybrid` package convention" + "USE THE CURRENT PACKAGE AND PROJECT" + loadedPackage := loadedMethod loadedPackage ] + ifNotNil: [ + "moving from current package to a hybrid project and package" + loadedPackage := hybridLoadedPackage. + loadedProject := hybridLoadedProject ] ] ] ] + ifFalse: [ + "use the existing package for method" + loadedPackage := loadedMethod loadedPackage ] ]. + + loadedPackage loadedProject == loadedProject + ifFalse: [ + self + error: + 'internal error - the expected loaded project ' , loadedProject name printString + , ' does not match the actual loaded project ' + , loadedPackage loadedProject name printString , ' of the package ' + , loadedPackage name printString , ' for the method ' , loadedClass name + , + (isMeta + ifTrue: [ ' class ' ] + ifFalse: [ '' ]) , '>>' , methodDef selector ]. + + ^ self + addOrUpdateMethodDefinition: methodDef + forClassNamed: className + isMeta: isMeta + inLoadedPackage: loadedPackage +] + +{ #category : '*rowan-obsolete' } +RwPrjBrowserTool >> addOrUpdateMethodDefinition: methodDef forClassNamed: className isMeta: isMeta inLoadedPackage: loadedPackage [ + "If the method is already installed in a different package, remove the method from that package. + If package name matches the name of the package of the class definition, then add the method + to the class definition. + If there is no matching class extension or the package name does not match, add the method + to a class extension in the named package. + Return the resulting compiled method" + + | projectTools classExtensionDef updateBlock projectDefinition packageDefinition projectSetDefinition loadedMethodToBeRemoved | + projectSetDefinition := RwProjectSetDefinition new. + + loadedMethodToBeRemoved := self + _loadedMethod: methodDef selector + inClassNamed: className + isMeta: isMeta + ifAbsent: [ + "no pre-existing method for this selector installed" + ]. + + projectTools := Rowan projectTools. + updateBlock := [ :cDef :pDef | + loadedMethodToBeRemoved + ifNil: [ + "no method needs to be remove, just add the method to the class or extension def" + isMeta + ifTrue: [ cDef addClassMethodDefinition: methodDef ] + ifFalse: [ cDef addInstanceMethodDefinition: methodDef ] ] + ifNotNil: [ :loadedMethod | + | loadedPackageForMethod | + loadedPackageForMethod := loadedMethod loadedPackage. + loadedPackageForMethod == loadedPackage + ifTrue: [ + "loaded method being updated in same package, sjust update the method def" + isMeta + ifTrue: [ cDef updateClassMethodDefinition: methodDef ] + ifFalse: [ cDef updateInstanceMethodDefinition: methodDef ] ] + ifFalse: [ + | loadedClassOrExtension projectDef packageDef crDef | + "loaded method in different package than new version of method" + projectDef := loadedPackageForMethod loadedProject asDefinition. + projectDef name = pDef name + ifTrue: [ + "both packages are in same project" + projectDef := pDef ] + ifFalse: [ + "each package in a different project, will need to load loaded method project as well" + projectSetDefinition addProject: projectDef ]. + packageDef := projectDef packageNamed: loadedPackageForMethod name. + loadedClassOrExtension := loadedMethod loadedClass. + crDef := loadedClassOrExtension isLoadedClass + ifTrue: [ packageDef classDefinitions at: loadedClassOrExtension name ] + ifFalse: [ packageDef classExtensions at: loadedClassOrExtension name ]. "remove the method from one package and add it to the other" + isMeta + ifTrue: [ + crDef removeClassMethod: methodDef selector. + cDef addClassMethodDefinition: methodDef ] + ifFalse: [ + crDef removeInstanceMethod: methodDef selector. + cDef addInstanceMethodDefinition: methodDef ] ] ]. + projectSetDefinition addProject: pDef. + projectTools load loadProjectSetDefinition: projectSetDefinition. + (self _loadedMethod: methodDef selector inClassNamed: className isMeta: isMeta) + handle ]. + + self + definitionsForClassNamed: className + ifFound: [ :classDef :packageDef :projectDef | + packageDef name = loadedPackage name + ifTrue: [ ^ updateBlock value: classDef value: projectDef ] + ifFalse: [ + "the named package is different from the class definition package" + ] ] + ifAbsent: [ + "no loaded class definition, so we probably need to add a class extension" + ]. + projectDefinition := loadedPackage loadedProject asDefinition. + packageDefinition := projectDefinition packageNamed: loadedPackage name. + + classExtensionDef := packageDefinition classExtensions + at: className + ifAbsent: [ + "no existing class extension definition ... create a new one" + classExtensionDef := RwClassExtensionDefinition newForClassNamed: className. + + packageDefinition addClassExtensionDefinition: classExtensionDef. + classExtensionDef ]. + + ^ updateBlock value: classExtensionDef value: projectDefinition +] diff --git a/rowan/src/Rowan-Tests-GemStone-36x/RwUnmanagedClassesV2Test.class.st b/rowan/src/Rowan-Tests-GemStone-36x/RwUnmanagedClassesV2Test.class.st index a837c6818..e77502fe0 100644 --- a/rowan/src/Rowan-Tests-GemStone-36x/RwUnmanagedClassesV2Test.class.st +++ b/rowan/src/Rowan-Tests-GemStone-36x/RwUnmanagedClassesV2Test.class.st @@ -341,7 +341,7 @@ RwUnmanagedClassesV2Test >> testCurrentTopazPackageFilein_02 [ inDictionary: symbolDictionary options: #(). managedMethod := unmanagedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName. @@ -413,7 +413,7 @@ RwUnmanagedClassesV2Test >> testCurrentTopazPackageFilein_03 [ inDictionary: symbolDictionary options: #(). managedMethod := unmanagedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName. @@ -612,7 +612,7 @@ RwUnmanagedClassesV2Test >> testMoveManagedMethod_01 [ inDictionary: symbolDictionary options: #(). managedMethod := unmanagedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName. @@ -669,7 +669,7 @@ RwUnmanagedClassesV2Test >> testMoveUnmanagedClass_01 [ category: 'unmanaged' environmentId: 0. managedMethod := unmanagedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName. @@ -862,7 +862,7 @@ RwUnmanagedClassesV2Test >> testRemoveAllMethods [ category: 'unmanaged' environmentId: 0. managedMethod := unmanagedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName. @@ -1363,7 +1363,7 @@ RwUnmanagedClassesV2Test >> testUnmanagedFilein_04 [ self assert: managedClass notNil. managedMethod := managedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName. @@ -1442,10 +1442,10 @@ baz ^3 self assert: managedClass notNil. managedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName1; - rwCompileExtensionMethod: 'baz ^3' + rwCompileMethod: 'baz ^3' category: 'extension' packageName: packageName2; yourself. @@ -1577,7 +1577,7 @@ RwUnmanagedClassesV2Test >> testUnpackageManagedMethod_01 [ inDictionary: symbolDictionary options: #(). managedMethod := unmanagedClass - rwCompileExtensionMethod: 'bar ^2' + rwCompileMethod: 'bar ^2' category: 'managed' packageName: packageName. diff --git a/rowan/src/Rowan-Tests/RwProjectAuditToolTest.class.st b/rowan/src/Rowan-Tests/RwProjectAuditToolTest.class.st index 524a57d81..9f5a608bc 100644 --- a/rowan/src/Rowan-Tests/RwProjectAuditToolTest.class.st +++ b/rowan/src/Rowan-Tests/RwProjectAuditToolTest.class.st @@ -401,79 +401,6 @@ RwProjectAuditToolTest >> testAuditDetails [ equals: #(differentMethodCategory) sort. ] -{ #category : 'tests' } -RwProjectAuditToolTest >> testClassBadExtensionName [ - - | packageTools projectName packageNames className packageName1 packageName2 theClass - fooMethod audit reasons | - packageTools := Rowan packageTools. - projectName := 'AuditProject'. - packageName1 := 'Audit-Core'. - packageName2 := 'Audit-Extensions'. - packageNames := {packageName1 . packageName2}. - className := 'AuditClass'. - - self - _loadProjectDefinition: projectName - packageNames: packageNames - defaultSymbolDictName: self _symbolDictionaryName1 - comment: 'project for testing audit api'. - - theClass := Object - rwSubclass: className - instVarNames: #(bar) - classVars: #() - classInstVars: #() - poolDictionaries: #() - category: packageName1 - options: #(). - - self assert: theClass rowanPackageName = packageName1. - - theClass - rwCompileMethod: 'bar ^bar' - category: 'Accessing' "'*' packageName1 asLowercase". - - fooMethod := theClass - rwCompileExtensionMethod: 'foo ^''foo''' - package: packageName2. - - self assert: (audit := Rowan projectTools audit auditForProjectNamed: projectName) isEmpty. - - "lets break it" - fooMethod := theClass - compileMethod: 'foo ^2' - dictionaries: Rowan image symbolList - category: ('*' , packageName1 asLowercase) asSymbol - intoMethodDict: nil - intoCategories: nil - environmentId: 0. - - self assert: (audit := Rowan projectTools audit auditForProjectNamed: projectName) size = 2. - - - reasons := ((audit at: packageName1) at: className) collect: [:auditDetail | auditDetail reason]. - self assert: reasons size equals: 2. - self - assert: reasons asSet asArray sort - equals: #(missingLoadedMethod rowanHybridExtensionCategoryMatchesClassPackage) sort. - - reasons := ((audit at: packageName2) at: className) collect: [:auditDetail | auditDetail reason]. - self assert: reasons size equals: 2. - self - assert: reasons asSet asArray sort - equals: #(differentMethodCategory methodsNotIdentical) sort. - -" - self assert: ( y := x at: packageName1) notNil; - assert: y size = 1; - assert: (y at: className) size = 1; - assert: (y := x at: packageName2 ) notNil; - assert: y size = 1; - assert: (y at: className) size = 1 -" -] - { #category : 'tests' } RwProjectAuditToolTest >> testClassCategoryViolation [ | packageTools projectName packageNames className packageName theClass audit reasons resolvedProject | @@ -569,113 +496,6 @@ RwProjectAuditToolTest >> testClassesNotIdentical [ equals: #(classesNotIdentical) sort. ] -{ #category : 'tests' } -RwProjectAuditToolTest >> testClassExtension [ - -| packageTools projectName packageNames className packageName1 packageName2 packageName3 theClass fooMethod audit reasons | - packageTools := Rowan packageTools. - projectName := 'AuditProject'. - packageName1 := 'Audit-Core'. - packageName2 := 'Audit-Extensions'. - packageName3 := 'Audit-Class-Extensions'. - packageNames := {packageName1 . packageName2 . packageName3}. - className := 'AuditClass'. - - self - _loadProjectDefinition: projectName - packageNames: packageNames - defaultSymbolDictName: self _symbolDictionaryName1 - comment: 'project for testing audit api'. - - theClass := Object - rwSubclass: className - instVarNames: #(bar) - classVars: #() - classInstVars: #() - poolDictionaries: #() - category: packageName1 - options: #(). - - self assert: theClass rowanPackageName = packageName1. - "self assert: theClass classHistory isEmpty." - "compile good class" - theClass class - rwCompileMethod: 'new ^super new ' - category: 'Instance creation'. - - theClass class - rwCompileExtensionMethod: 'new2 ^self new' - package: packageName2. - - theClass class - rwCompileExtensionMethod: 'new3 ^self new initialize' - package: packageName3. - - theClass - rwCompileMethod: 'bar ^bar' - category: 'Accessing' "'*' packageName1 asLowercase". - - fooMethod := theClass - rwCompileExtensionMethod: 'foo ^''foo''' - package: packageName2. - - audit:= Rowan projectTools audit auditForProjectNamed: 'AuditProject'. - self assert: audit isEmpty. - - fooMethod := theClass - compileMethod: 'bar: aBar bar := aBar' - dictionaries: Rowan image symbolList - category: ('*' , packageName2 asLowercase) asSymbol - intoMethodDict: nil - intoCategories: nil - environmentId: 0. - - fooMethod := theClass class - compileMethod: 'new2 ^self new' - dictionaries: Rowan image symbolList - category: ('*' , packageName2 asLowercase) asSymbol - intoMethodDict: nil - intoCategories: nil - environmentId: 0. - - fooMethod := theClass class - compileMethod: 'new3 ^self new initialize' - dictionaries: Rowan image symbolList - category: ('*' , packageName3 asLowercase) asSymbol - intoMethodDict: nil - intoCategories: nil - environmentId: 0. - - fooMethod := theClass class - compileMethod: 'new ^super new ' - dictionaries: Rowan image symbolList - category: #'*Instance creation' "non existing extension/package" - intoMethodDict: nil - intoCategories: nil - environmentId: 0. - - audit := Rowan projectTools audit auditForProjectNamed: 'AuditProject'. - self deny: audit isEmpty. - - reasons := ((audit at: packageName1) at: className) collect: [:auditDetail | auditDetail reason]. - self assert: reasons size equals: 6. - self - assert: reasons asSet asArray sort - equals: #(missingLoadedMethod methodsNotIdentical differentMethodCategory) sort. - - reasons := ((audit at: packageName2) at: className) collect: [:auditDetail | auditDetail reason]. - self assert: reasons size equals: 1. - self - assert: reasons asSet asArray sort - equals: #(methodsNotIdentical) sort. - - reasons := ((audit at: packageName3) at: className) collect: [:auditDetail | auditDetail reason]. - self assert: reasons size equals: 1. - self - assert: reasons asSet asArray sort - equals: #(methodsNotIdentical) sort. -] - { #category : 'tests' } RwProjectAuditToolTest >> testClassVars [ | projectName packageNames className packageName classDefinition browserTool testClass testClassB x | diff --git a/rowan/src/Rowan-Tools-Core/RwPrjBrowserTool.class.st b/rowan/src/Rowan-Tools-Core/RwPrjBrowserTool.class.st index 64db534d9..d18bd0611 100644 --- a/rowan/src/Rowan-Tools-Core/RwPrjBrowserTool.class.st +++ b/rowan/src/Rowan-Tools-Core/RwPrjBrowserTool.class.st @@ -355,189 +355,6 @@ RwPrjBrowserTool >> addOrUpdateMethod: methodSource dictionaries: aSymbolList in handle ] -{ #category : 'method browsing' } -RwPrjBrowserTool >> addOrUpdateMethod: methodSource inProtocol: hybridPackageName forClassNamed: className isMeta: isMeta [ - "If the method is already installed in a different package, remove the method from that package. - If package name matches the name of the package of the class definition, then add the method - to the class definition. - If there is no matching class extension or the package name does not match, add the method - to a class extension in the named package. - Return the resulting compiled method" - - "a hybrid package name has a leading '*' followed by the name of a package ... - where the hybrid package name is not expected to preserve case" - - "this method is only needed for the transition from Oscar 3.x to Oscar 4.0 (Rowan V2 aware Jadeite" - - | methodDef loadedProject loadedPackage couldBeHybrid hybridLoadedPackage hybridLoadedProject loadedClass | - couldBeHybrid := (hybridPackageName at: 1) = $*. - couldBeHybrid - ifTrue: [ - hybridLoadedPackage := Rowan image - loadedHybridPackageNamed: hybridPackageName - ifAbsent: [ ]. - hybridLoadedPackage - ifNotNil: [ - | pkgConvention | - hybridLoadedProject := hybridLoadedPackage loadedProject. - pkgConvention := hybridLoadedProject packageConvention. - (pkgConvention = 'RowanHybrid' or: [ pkgConvention = 'Monticello' ]) - ifTrue: [ - | classPackageName "everything is cool" | - classPackageName := (Rowan image objectNamed: className) rowanPackageName. - classPackageName = hybridLoadedPackage name - ifTrue: [ - "https://github.com/GemTalk/Rowan/issues/802" - self - error: - 'extension category name ' , hybridPackageName printString - , ' must not match class package name (' , classPackageName , ')' ] ] - ifFalse: [ - "the project associated with the hybridPackageName _is NOT_ using the `RowanHybrid` package convention - questionable use of hybrid convention in a non-hybrid project" - Warning - signal: - 'The package convention for this project (' - , hybridLoadedProject name printString - , - ') is ''Rowan'' and a leading $* in the category is not used to denote a target package for any methods placed in this category'. - couldBeHybrid := false ] ] ]. - methodDef := RwMethodDefinition - newForSource: methodSource - protocol: hybridPackageName. - (self - _loadedMethod: methodDef selector - inClassNamed: className - isMeta: isMeta - ifAbsent: [ ]) - ifNil: [ - "new method extract project information from the class" - (Rowan image loadedClassNamed: className ifAbsent: [ ]) - ifNil: [ - "unpackaged class?" - couldBeHybrid - ifTrue: [ - hybridLoadedPackage - ifNil: [ - self - error: - 'A package for package name ' , hybridPackageName printString - , ' was not found.' ]. - hybridLoadedProject - ifNil: [ - self - error: - 'Attempt to add a method to an unpackaged class ' , className printString - , ', while using `hybrid-style` method protocol ' - , hybridPackageName printString - , - ' for a project that does not use the `RowanHybrid` package convention.' ]. - loadedPackage := hybridLoadedPackage. - loadedProject := hybridLoadedProject ] - ifFalse: [ - | theBehavior | - "Adding unpackaged method to an unpackaged class - if permitted" - theBehavior := Rowan image objectNamed: className. - isMeta - ifTrue: [ theBehavior := theBehavior class ]. - RwPerformingUnpackagedEditNotification - signal: - 'Attempt to add or modify an unpackage method in the class ' - , className printString - , '. The modification will not be tracked by Rowan'. - ^ theBehavior - compileMethod: methodSource - dictionaries: Rowan image symbolList - category: hybridPackageName - environmentId: 0 "Notification resumed, so continue with add/modify" ] ] - ifNotNil: [ :theLoadedClass | - loadedClass := theLoadedClass. - couldBeHybrid - ifTrue: [ - hybridLoadedPackage - ifNil: [ - self - error: - 'A package for package name ' , hybridPackageName printString - , ' was not found.' ]. - hybridLoadedProject - ifNil: [ - self - error: - 'Attempt to add a method to an unpackaged class ' , className printString - , ', while using `hybrid-style` method protocol ' - , hybridPackageName printString ]. - loadedPackage := hybridLoadedPackage. - loadedProject := hybridLoadedProject ] - ifFalse: [ - "new method for packaged class, so add method to the class' package" - loadedProject := theLoadedClass loadedProject. - loadedPackage := theLoadedClass loadedPackage ] ] ] - ifNotNil: [ :loadedMethod | - | isHybrid | - "change to existing loaded method - keep in mind that the method could be being moved between packages via protocol change" - loadedProject := loadedMethod loadedProject. - loadedClass := loadedMethod loadedClass. - isHybrid := loadedProject packageConvention = 'RowanHybrid'. - couldBeHybrid - ifTrue: [ - "protocol has leading *" - hybridLoadedPackage - ifNil: [ - "questionable use of hybrid protocol in a non-RowanHybrid project, but legal" - loadedPackage := loadedMethod loadedPackage ] - ifNotNil: [ - isHybrid - ifTrue: [ - "the current project for the method is using the `RowanHybrid` package convention" - hybridLoadedProject - ifNil: [ - "VERY questionable use of hybrid protocol, package matching the hyybrid protocol was found, but the project of the package is not using `RowanHybrid` package convention, while the current project _IS_ using hybrid protocol --- ILLEGAL" - self - error: - 'Attempt to use RowanHybrid convention ' , hybridPackageName printString - , ' for a package ' , hybridLoadedPackage name printString - , ' that belongs to a project ' - , hybridLoadedPackage loadedProject name printString - , ' that is not using `RowanHybrid` package convention.' ] - ifNotNil: [ - "moving from one hybrid package to another (or same) hybrid package" - loadedPackage := hybridLoadedPackage. - loadedProject := hybridLoadedProject ] ] - ifFalse: [ - "the current project is NOT using the `RowanHybrid` package convention" - hybridLoadedProject - ifNil: [ - "Questionable use of hybrid protocol, package matching the hyybrid protocol was found, but the project of the package is not using `RowanHybrid` package convention" - "USE THE CURRENT PACKAGE AND PROJECT" - loadedPackage := loadedMethod loadedPackage ] - ifNotNil: [ - "moving from current package to a hybrid project and package" - loadedPackage := hybridLoadedPackage. - loadedProject := hybridLoadedProject ] ] ] ] - ifFalse: [ - "use the existing package for method" - loadedPackage := loadedMethod loadedPackage ] ]. - - loadedPackage loadedProject == loadedProject - ifFalse: [ - self - error: - 'internal error - the expected loaded project ' , loadedProject name printString - , ' does not match the actual loaded project ' - , loadedPackage loadedProject name printString , ' of the package ' - , loadedPackage name printString , ' for the method ' , loadedClass name - , - (isMeta - ifTrue: [ ' class ' ] - ifFalse: [ '' ]) , '>>' , methodDef selector ]. - - ^ self - addOrUpdateMethodDefinition: methodDef - forClassNamed: className - isMeta: isMeta - inLoadedPackage: loadedPackage -] - { #category : 'method browsing' } RwPrjBrowserTool >> addOrUpdateMethod: methodSource inProtocol: protocol forClassNamed: className isMeta: isMeta inPackageNamed: packageName [ "If the method is already installed in a different package, remove the method from that package. @@ -556,97 +373,6 @@ RwPrjBrowserTool >> addOrUpdateMethod: methodSource inProtocol: protocol forClas inPackageNamed: packageName ] -{ #category : 'method browsing' } -RwPrjBrowserTool >> addOrUpdateMethodDefinition: methodDef forClassNamed: className isMeta: isMeta inLoadedPackage: loadedPackage [ - "If the method is already installed in a different package, remove the method from that package. - If package name matches the name of the package of the class definition, then add the method - to the class definition. - If there is no matching class extension or the package name does not match, add the method - to a class extension in the named package. - Return the resulting compiled method" - - | projectTools classExtensionDef updateBlock projectDefinition packageDefinition projectSetDefinition loadedMethodToBeRemoved | - projectSetDefinition := RwProjectSetDefinition new. - - loadedMethodToBeRemoved := self - _loadedMethod: methodDef selector - inClassNamed: className - isMeta: isMeta - ifAbsent: [ - "no pre-existing method for this selector installed" - ]. - - projectTools := Rowan projectTools. - updateBlock := [ :cDef :pDef | - loadedMethodToBeRemoved - ifNil: [ - "no method needs to be remove, just add the method to the class or extension def" - isMeta - ifTrue: [ cDef addClassMethodDefinition: methodDef ] - ifFalse: [ cDef addInstanceMethodDefinition: methodDef ] ] - ifNotNil: [ :loadedMethod | - | loadedPackageForMethod | - loadedPackageForMethod := loadedMethod loadedPackage. - loadedPackageForMethod == loadedPackage - ifTrue: [ - "loaded method being updated in same package, sjust update the method def" - isMeta - ifTrue: [ cDef updateClassMethodDefinition: methodDef ] - ifFalse: [ cDef updateInstanceMethodDefinition: methodDef ] ] - ifFalse: [ - | loadedClassOrExtension projectDef packageDef crDef | - "loaded method in different package than new version of method" - projectDef := loadedPackageForMethod loadedProject asDefinition. - projectDef name = pDef name - ifTrue: [ - "both packages are in same project" - projectDef := pDef ] - ifFalse: [ - "each package in a different project, will need to load loaded method project as well" - projectSetDefinition addProject: projectDef ]. - packageDef := projectDef packageNamed: loadedPackageForMethod name. - loadedClassOrExtension := loadedMethod loadedClass. - crDef := loadedClassOrExtension isLoadedClass - ifTrue: [ packageDef classDefinitions at: loadedClassOrExtension name ] - ifFalse: [ packageDef classExtensions at: loadedClassOrExtension name ]. "remove the method from one package and add it to the other" - isMeta - ifTrue: [ - crDef removeClassMethod: methodDef selector. - cDef addClassMethodDefinition: methodDef ] - ifFalse: [ - crDef removeInstanceMethod: methodDef selector. - cDef addInstanceMethodDefinition: methodDef ] ] ]. - projectSetDefinition addProject: pDef. - projectTools load loadProjectSetDefinition: projectSetDefinition. - (self _loadedMethod: methodDef selector inClassNamed: className isMeta: isMeta) - handle ]. - - self - definitionsForClassNamed: className - ifFound: [ :classDef :packageDef :projectDef | - packageDef name = loadedPackage name - ifTrue: [ ^ updateBlock value: classDef value: projectDef ] - ifFalse: [ - "the named package is different from the class definition package" - ] ] - ifAbsent: [ - "no loaded class definition, so we probably need to add a class extension" - ]. - projectDefinition := loadedPackage loadedProject asDefinition. - packageDefinition := projectDefinition packageNamed: loadedPackage name. - - classExtensionDef := packageDefinition classExtensions - at: className - ifAbsent: [ - "no existing class extension definition ... create a new one" - classExtensionDef := RwClassExtensionDefinition newForClassNamed: className. - - packageDefinition addClassExtensionDefinition: classExtensionDef. - classExtensionDef ]. - - ^ updateBlock value: classExtensionDef value: projectDefinition -] - { #category : 'package browsing' } RwPrjBrowserTool >> addPackageNamed: packageName toComponentNamed: componentName andProjectNamed: projectName [ | projectDefinition |