overwrittenExtensionMethods handling
authorClaus Gittinger <cg@exept.de>
Mon, 12 Oct 2009 19:26:08 +0200
changeset 12213 73371949b807
parent 12212 0333af779522
child 12214 96d417c20fb8
overwrittenExtensionMethods handling
ProjectDefinition.st
--- a/ProjectDefinition.st	Mon Oct 12 19:17:14 2009 +0200
+++ b/ProjectDefinition.st	Mon Oct 12 19:26:08 2009 +0200
@@ -3870,7 +3870,7 @@
         [:package |
             (package ~= myPackageID) ifTrue:[
                 true "(package startsWith:'stx:') not" ifTrue:[
-                    package ~= Project noProjectID ifTrue:[
+                    package ~= PackageId noProjectID ifTrue:[
                         requiredPackages add:package.
                     ]
                 ]
@@ -3953,7 +3953,7 @@
     myPackage := self package.
     ^ Smalltalk allProjectIDs 
         select:[:projectID |
-            projectID ~= Project noProjectID 
+            projectID ~= PackageId noProjectID 
             and:[ (projectID asPackageId parentPackage) = myPackage ]].
 
     "
@@ -3992,6 +3992,20 @@
     ^ safeForOverwrittenMethods notEmptyOrNil
 !
 
+methodOverwrittenBy:aMethod
+    "return the (hidden) original method, which was located in another package
+     and which got overwritten by one of my extension methods. Nil if there is none."
+
+    |mclass selector oldPackage|
+
+    mclass := aMethod mclass.
+    selector := aMethod selector.
+    oldPackage := extensionOverwriteInfo at:(mclass name,'>>',selector) ifAbsent:nil.
+    oldPackage isNil ifTrue:[^ nil].
+    ^ oldPackage asPackageId projectDefinition 
+        savedOverwrittenMethodForClass:mclass selector:selector.
+!
+
 rememberOverwrittenExtensionMethods
     "before loading, tell other packages to keep a safe reference to any method
      which gets overloaded by me, and also remember here, whome I have overloaded.
@@ -4000,18 +4014,22 @@
         b) correct unloading of myself"
 
     self extensionMethodNames pairWiseDo:[:className :selector |
-        |class oldMethod oldPackage|
+        |class oldMethod oldPackage defClass|
 
         class := Smalltalk classNamed:className.
         oldMethod := class compiledMethodAt:selector.
         oldMethod notNil ifTrue:[
-            oldPackage := oldMethod package asPackageId.
-            oldPackage projectDefinitionClass
-                rememberOverwrittenMethod:oldMethod inClass:class.
-            extensionOverwriteInfo isNil ifTrue:[
-                extensionOverwriteInfo := Dictionary new.
+            oldPackage := oldMethod package.
+            oldPackage ~= PackageId noProjectID ifTrue:[
+                defClass := oldPackage asPackageId projectDefinitionClass.
+                defClass notNil ifTrue:[
+                    defClass rememberOverwrittenMethod:oldMethod inClass:class.
+                    extensionOverwriteInfo isNil ifTrue:[
+                        extensionOverwriteInfo := Dictionary new.
+                    ].
+                    extensionOverwriteInfo at:(className,'>>',selector) put:oldPackage.
+                ]
             ].
-            extensionOverwriteInfo at:(className,'>>',selector) put:oldPackage.
         ].
     ].
 !
@@ -4045,6 +4063,12 @@
         safeForOverwrittenMethods := Dictionary new.
     ].
     safeForOverwrittenMethods at:(aClass name -> selector) put:oldMethod.
+!
+
+savedOverwrittenMethodForClass:aClass selector:aSelector
+    "return one of my saved original methods"
+
+    ^ safeForOverwrittenMethods at:(aClass name,'>>',aSelector)
 ! !
 
 !ProjectDefinition class methodsFor:'private-loading'!
@@ -4322,7 +4346,7 @@
                                 ifFalse:[ self searchForSubProjects ]) asSet.
 
     ignoredPackages add:self package.
-    ignoredPackages add:Project noProjectID.
+    ignoredPackages add:PackageId noProjectID.
 
     "now map classes to packages and collect the reasons"
     requiredPackageReasons := Dictionary new.
@@ -4597,11 +4621,11 @@
 !ProjectDefinition class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.243 2009-10-12 16:45:41 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.244 2009-10-12 17:26:08 cg Exp $'
 !
 
 version_CVS
-    ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.243 2009-10-12 16:45:41 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.244 2009-10-12 17:26:08 cg Exp $'
 ! !
 
 ProjectDefinition initialize!