--- a/ProjectDefinition.st Tue Apr 16 14:27:04 2013 +0200
+++ b/ProjectDefinition.st Thu Apr 18 20:41:50 2013 +0200
@@ -12,11 +12,11 @@
"{ Package: 'stx:libbasic' }"
Object subclass:#ProjectDefinition
- instanceVariableNames:''
- classVariableNames:'LibraryType GUIApplicationType NonGUIApplicationType
- PackagesBeingLoaded Verbose AbbrevDictionary AccessLock'
- poolDictionaries:''
- category:'System-Support-Projects'
+ instanceVariableNames:''
+ classVariableNames:'LibraryType GUIApplicationType NonGUIApplicationType
+ PackagesBeingLoaded Verbose AbbrevDictionary AccessLock'
+ poolDictionaries:''
+ category:'System-Support-Projects'
!
ProjectDefinition class instanceVariableNames:'safeForOverwrittenMethods extensionOverwriteInfo projectIsLoaded'
@@ -27,10 +27,10 @@
!
Object subclass:#AbbrevEntry
- instanceVariableNames:'className fileName category numClassInstVars'
- classVariableNames:''
- poolDictionaries:''
- privateIn:ProjectDefinition
+ instanceVariableNames:'className fileName category numClassInstVars'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:ProjectDefinition
!
!ProjectDefinition class methodsFor:'documentation'!
@@ -152,7 +152,15 @@
class := Smalltalk classNamed:packageDefinitionClassName.
class isNil ifTrue:[
doCreateIfAbsent ifTrue:[
- class := self newForPackage:aPackageID.
+ typeOrNil = GUIApplicationType ifTrue:[
+ class := ApplicationDefinition newForPackage:aPackageID.
+ ] ifFalse:[
+ typeOrNil = NonGUIApplicationType ifTrue:[
+ class := ApplicationDefinition newForPackage:aPackageID.
+ ] ifFalse:[
+ class := LibraryDefinition newForPackage:aPackageID.
+ ]
+ ].
"setup before prerequisites are defined"
class setupForType:typeOrNil.
"/ look what is there and include it; is this ok ?
@@ -876,6 +884,33 @@
"Created: / 30-08-2007 / 18:28:28 / cg"
!
+excludeMethodFor:selector inClassNamed:className usingCompiler:compilerOrNil
+ "exclude (remove from extensionList) a method by name.
+ Because this requires compilation of my extensionMethodNames-method, a compiler can be passed in,
+ which has to do the job.
+ This is used by the systembrowser to pass in a CodeGeneratorTool with undo support.
+ If nil is passed in, the recurlar compiler is used (no undo support)"
+
+ |oldSpec newSpec newCode extensionMethods idx|
+
+ oldSpec := self extensionMethodNames.
+ newSpec := oldSpec copy.
+ extensionMethods := self extensionMethods.
+
+ idx := (1 to:newSpec size-1 by:2)
+ detect:[:i |
+ ((newSpec at:i) = className)
+ and:[ (newSpec at:i+1) = selector ]]
+ ifNone:nil.
+ idx isNil ifTrue:[ ^ self ].
+
+ "/ attention: there are two spec-elements per method
+ newSpec := newSpec removeFromIndex:idx toIndex:idx+1.
+
+ newCode := self extensionMethodNames_code_For:newSpec.
+ self compile:newCode categorized:'description - contents' using:compilerOrNil
+!
+
excludeMethods:toRemove usingCompiler:compilerOrNil
"exclude (remove from extensionList) a number of methods.
Because this requires compilation of my extensionMethodNames-method, a compiler can be passed in,
@@ -895,11 +930,15 @@
(extensionMethods includes:eachMethodToRemove) ifTrue:[
className := eachMethodToRemove mclass name.
selector := eachMethodToRemove selector.
- idx := (1 to:newSpec size-1 by:2) detect:[:i |
- ((newSpec at:i) = className)
- and:[ (newSpec at:i+1) = selector ]].
-
- newSpec := newSpec removeFromIndex:idx toIndex:idx+1
+ idx := (1 to:newSpec size-1 by:2)
+ detect:[:i |
+ ((newSpec at:i) = className)
+ and:[ (newSpec at:i+1) = selector ]]
+ ifNone:nil.
+ idx notNil ifTrue:[
+ "/ attention: there are two spec-elements per method
+ newSpec := newSpec removeFromIndex:idx toIndex:idx+1
+ ]
].
].
@@ -1001,6 +1040,29 @@
self classNamesAndAttributes:newSpec usingCompiler:compilerOrNil
!
+updateContentsMethodsCodeUsingCompiler:compilerOrNil ignoreOldDefinition:doRegenerate
+ "regenerate the contents-describing methods.
+ This searches through the system and picks classes and extension methods
+ which have me as package and lists them in the generated class-
+ and extensionMethods methods.
+ If doRegenerate is true, forget any any previous contents info;
+ otherwise, merge new items into the existing lists."
+
+ Class packageQuerySignal
+ answer:self package
+ do:[
+ self
+ forEachContentsMethodsCodeToCompileDo:
+ [:code :category |
+ (compilerOrNil ? self theMetaclass compilerClass)
+ compile:code
+ forClass:self theMetaclass
+ inCategory:category.
+ ]
+ ignoreOldDefinition:doRegenerate
+ ].
+!
+
updateExtensionMethodNamesUsingCompiler:compilerOrNil
"set the set of extension methods
Because this requires compilation of my extensionMethodNames-method,
@@ -1011,6 +1073,29 @@
newCode := self extensionMethodNames_code.
self compile:newCode categorized:'description - contents' using:compilerOrNil
+!
+
+updateMethodsCodeUsingCompiler:compilerOrNil ignoreOldDefinition:doRegenerate
+ "regenerate the all contents- plus version describing methods.
+ This searches through the system and picks classes and extension methods
+ which have me as package and lists them in the generated class-
+ and extensionMethods methods.
+ If doRegenerate is true, forget any any previous contents info;
+ otherwise, merge new items into the existing lists."
+
+ Class packageQuerySignal
+ answer:self package
+ do:[
+ self
+ forEachMethodsCodeToCompileDo:
+ [:code :category |
+ (compilerOrNil ? self theMetaclass compilerClass)
+ compile:code
+ forClass:self theMetaclass
+ inCategory:category.
+ ]
+ ignoreOldDefinition:doRegenerate
+ ].
! !
@@ -1398,9 +1483,10 @@
|subProjects|
- subProjects := self subProjects asSet.
- subProjects removeAllFoundIn:self excludedFromSubProjects.
- subProjects remove:self package ifAbsent:[].
+ subProjects := self subProjects asNewSet.
+ subProjects
+ removeAllFoundIn:self excludedFromSubProjects;
+ remove:self package ifAbsent:[].
^ subProjects
!
@@ -1525,6 +1611,12 @@
!
forEachContentsMethodsCodeToCompileDo:aTwoArgBlock ignoreOldDefinition:ignoreOldDefinition
+ "generate code for each contents-specifying method
+ (classesAndAttributes, extensionMethodNames, etc.),
+ and evaluate aTwoArgBlock on it, passing in the code and the method's category.
+ If ignoreOldDefinition is true, new code is generated (class/method scan);
+ otherwise, new items are added to the existing lists"
+
aTwoArgBlock
value:(self classNamesAndAttributes_code_ignoreOldEntries:ignoreOldDefinition ignoreOldDefinition:ignoreOldDefinition)
value:'description - contents'.
@@ -1561,10 +1653,19 @@
!
forEachMethodsCodeToCompileDo:aTwoArgBlock
+ "update code for each method (contents plus version info),
+ and evaluate aTwoArgBlock on it, passing in the code and the method's category.
+ New items are added to the existing lists"
+
self forEachMethodsCodeToCompileDo:aTwoArgBlock ignoreOldDefinition:false
!
forEachMethodsCodeToCompileDo:aTwoArgBlock ignoreOldDefinition:ignoreOldDefinition
+ "generate code for each method (contents plus version info),
+ and evaluate aTwoArgBlock on it, passing in the code and the method's category.
+ If ignoreOldDefinition is true, new code is generated (class/method scan);
+ otherwise, new items are added to the existing lists"
+
self
forEachContentsMethodsCodeToCompileDo:aTwoArgBlock
ignoreOldDefinition:ignoreOldDefinition.
@@ -3674,11 +3775,10 @@
"/ a must come before b iff:
"/ b is a subclass of a
"/ b has a private class which is a subclass of a
- "/ a is a sharedPool, used by b
+ "/ b is using the sharedPool, a
|mustComeBefore pivateClassesOfB|
- mustComeBefore := false.
mustComeBefore := (a isSharedPool and:[(b sharedPoolNames includes: a name)]).
mustComeBefore := mustComeBefore or:[b isSubclassOf:a].
mustComeBefore ifFalse:[
@@ -4163,7 +4263,7 @@
"
"cg: changed to not go and remake librun"
- (self allPreRequisitesSorted "copyWith:'stx:librun'") do:[:eachProjectId |
+ (self allPreRequisitesSorted:#effectiveMandatoryPreRequisites "#effectivePreRequisites") do:[:eachProjectId |
s tab; nextPutAll:'pushd ';
nextPutAll:(self msdosPathToPackage:eachProjectId from:myProjectId);
nextPutLine:' & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "'.
@@ -4181,7 +4281,7 @@
^ String streamContents:[:s |
"cg: changed to not go and remake librun"
- (self allPreRequisitesSorted "copyWith:'stx:librun'") do:[:projectID |
+ (self allPreRequisitesSorted:#effectiveMandatoryPreRequisites "#effectivePreRequisites") do:[:projectID |
libPath := self pathToPackage_unix:projectID.
s tab; nextPutAll: 'cd ', libPath; nextPutLine:' && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"'.
].
@@ -5158,10 +5258,6 @@
compile:someCode
forClass:self theMetaclass
inCategory:category
- notifying:nil
- install:true
- skipIfSame:true
- silent:true.
]
"Created: / 23-08-2006 / 14:36:53 / cg"
@@ -5355,19 +5451,16 @@
!
searchForClassesWithProject: aProjectID
+ "answer all public and private classes belonging to aProjectID"
^ Smalltalk allClasses
- select:[:cls | (cls package = aProjectID) ].
+ select:[:cls | cls package = aProjectID].
"
- self searchForClassesWithProject: #'bosch:dapasx'
- self searchForClassesWithProject: #'bosch:dapasx/datenbasis'
- self searchForClassesWithProject: #'bosch:dapasx/kernel'
+ self searchForClassesWithProject: #'exept:ctypes'
"
"Created: / 07-08-2006 / 20:42:39 / fm"
- "Modified: / 07-08-2006 / 21:56:25 / fm"
- "Modified: / 16-08-2006 / 18:50:48 / User"
!
searchForExtensions
@@ -5561,7 +5654,7 @@
^ true
'
categorized:'description'.
- self superclass: ApplicationDefinition.
+ self setSuperclass: ApplicationDefinition.
^ self
].
@@ -5574,12 +5667,12 @@
^ false
'
categorized:'description'.
- self superclass: ApplicationDefinition.
+ self setSuperclass: ApplicationDefinition.
^ self
].
self theMetaclass removeSelector: #isGUIApplication.
- self superclass: LibraryDefinition.
+ self setSuperclass: LibraryDefinition.
^ self.
"Created: / 23-08-2006 / 14:26:10 / cg"
@@ -5601,6 +5694,18 @@
!ProjectDefinition class methodsFor:'private-extension handling'!
+extensionOverwriteInfo
+ ^ extensionOverwriteInfo
+!
+
+fetchSlotsFrom:myFirstIncarnation
+ "this is invoked in a just loaded instance of myself,
+ to fetch the safe and extensionInfo from my first incarnation"
+
+ safeForOverwrittenMethods := myFirstIncarnation safeForOverwrittenMethods.
+ extensionOverwriteInfo := myFirstIncarnation extensionOverwriteInfo.
+!
+
hasSavedOverwrittenMethods
"true, if any of my methods was overwritten by another loaded package.
These methods are now in my safe"
@@ -5707,6 +5812,10 @@
].
!
+safeForOverwrittenMethods
+ ^ safeForOverwrittenMethods
+!
+
savedOverwrittenMethodForClass:aClass selector:aSelector
"return one of my saved original methods"
@@ -5781,18 +5890,6 @@
"Modified: / 27-11-2012 / 16:15:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-extensionOverwriteInfo
- ^ extensionOverwriteInfo
-!
-
-fetchSlotsFrom:myFirstIncarnation
- "this is invoked in a just loaded instance of myself,
- to fetch the safe and extensionInfo from my first incarnation"
-
- safeForOverwrittenMethods := myFirstIncarnation safeForOverwrittenMethods.
- extensionOverwriteInfo := myFirstIncarnation extensionOverwriteInfo.
-!
-
loadAllAutoloadedClasses
self allClasses do:[:cls | cls autoload]
@@ -6222,10 +6319,6 @@
"Created: / 19-06-2010 / 11:36:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-safeForOverwrittenMethods
- ^ safeForOverwrittenMethods
-!
-
unloadAllClasses
Transcript showCR:'unloading not yet fully supported'
!
@@ -6311,6 +6404,44 @@
"Modified: / 30-05-2007 / 12:48:30 / cg"
!
+addReferencesToExtensionMethodsIn:someClasses to:usedMethodReasons
+ "helper for searchForPreRequisites: search for sends of a selector which
+ is defined in an extension method (in the set of passed-in methods).
+ If found, add the extension method and a reason string to usedReasons.
+ This should find especially sends to extension methods from libcompat."
+
+ |allExtensionMethods allRealExtensions allRealExtensionSelectors|
+
+ allExtensionMethods := Smalltalk allExtensions.
+ "/ only care for methods which are not already implemented in an extension methods's superclass
+ allRealExtensions := allExtensionMethods
+ select:[:mthd |
+ |superClass|
+ superClass := mthd mclass superclass.
+ (superClass isNil or:[superClass whichClassIncludesSelector:mthd selector]) isNil
+ ].
+
+ allRealExtensionSelectors := allRealExtensions collect:[:m | m selector].
+
+ someClasses do:[:eachClass |
+ eachClass instAndClassMethodsDo:[:method |
+ |resources extensionsSent|
+
+ resources := method resources.
+ (resources isNil
+ or:[ ((resources includesKey:#'ignoreInPrerequisites') not
+ and:[(resources includesKey:#'example') not])])
+ ifTrue:[
+ extensionsSent := allRealExtensions select:[:ext | method messagesSent includes:ext selector].
+ extensionsSent do:[:eachExtensionMethod |
+ (usedMethodReasons at:eachExtensionMethod ifAbsentPut:[Set new])
+ add:(eachExtensionMethod selector, ' - sent by ', method mclass name,'>>',method selector)
+ ]
+ ]
+ ]
+ ]
+!
+
allPreRequisites
"answer all (recursive) prerequisite project ids of myself - in random order."
@@ -6512,19 +6643,40 @@
"
!
+effectiveMandatoryPreRequisites
+ "get the preRequisites, that are not excluded"
+
+ self mandatoryPreRequisites notEmpty ifTrue:[
+ "this is a new subclass - avoid overhead"
+ ^ OrderedSet new
+ addAll:self mandatoryPreRequisites;
+ addAll:self includedInPreRequisites;
+ removeAllFoundIn:self excludedFromPreRequisites;
+ yourself.
+ ].
+
+ "I am an old subclass, where #preRequisites returns a plain array"
+ ^ Set new
+ addAll:self preRequisites;
+ addAll:self includedInPreRequisites;
+ removeAllFoundIn:self excludedFromPreRequisites;
+ remove:self package ifAbsent:[];
+ yourself.
+!
+
effectivePreRequisites
"get the preRequisites, that are not excluded.
This method appears to be obsolete, because its functionality
is now included in #preRequisites.
- But is hat to be kept for backward compatibilty with old
- existant subclasses."
+ But is to be kept for backward compatibilty with old
+ existing subclasses."
self mandatoryPreRequisites notEmpty ifTrue:[
"this is a new subclass - avoid overhead"
^ self preRequisites.
].
- "I am an old sublclass, where #preRequisites returns a plain array"
+ "I am an old subclass, where #preRequisites returns a plain array"
^ Set new
addAll:self preRequisites;
addAll:self includedInPreRequisites;
@@ -6537,7 +6689,7 @@
"answer a Dictionary where the keys are the prerequisite package for this package
and the values are a Set of reasons, why each package is required"
- ^ self searchForPreRequisites:self package withSubProjects:true
+ ^ self searchForPreRequisites:self package
"
self searchForPreRequisites
@@ -6581,13 +6733,14 @@
Referenced prereqs are due to elements accessed at execution time (such as globals)"
|requiredClasses mandatoryClassesForLoadingWithReasons referencedClassesWithReasons
- ignoredPackages packageExtractionBlock mandatoryPackages referencedPackages|
+ ignoredPackages packageExtractionBlock mandatoryPackageReasons referencedPackageReasons referencedMethodsWithReasons|
mandatoryClassesForLoadingWithReasons := Dictionary new.
referencedClassesWithReasons := Dictionary new.
+ referencedMethodsWithReasons := Dictionary new.
"my classes are required"
- requiredClasses := (self searchForClassesWithProject: packageId) asSet.
+ requiredClasses := self searchForClassesWithProject: packageId.
withSubProjectsBoolean ifTrue:[
"my subproject's classes are required"
@@ -6596,11 +6749,21 @@
].
].
- "all superclasses of my classes and my subProject's classes (if required) are mandatory"
+ "all superclasses of my classes
+ and my subProject's classes (if required) are mandatory.
+ All shared pools used by my classes are required as well"
requiredClasses do:[:cls |
cls allSuperclassesDo:[:eachSuperclass |
(mandatoryClassesForLoadingWithReasons at: eachSuperclass ifAbsentPut:[OrderedSet new])
add: (eachSuperclass name, ' - superclass of ', cls name).
+ ].
+ cls sharedPools do:[:eachSharedPool |
+ (mandatoryClassesForLoadingWithReasons at: eachSharedPool ifAbsentPut:[OrderedSet new])
+ add: (eachSharedPool name, ' - shared pool used by ', cls name).
+ eachSharedPool allSuperclassesDo:[:eachSuperclass |
+ (mandatoryClassesForLoadingWithReasons at: eachSuperclass ifAbsentPut:[OrderedSet new])
+ add: (eachSuperclass name, ' - superclass of shared pool ', eachSharedPool name).
+ ]
]
].
"all classes for which I define extensions are mandatory"
@@ -6620,9 +6783,11 @@
self addReferencesToClassesFromGlobalsIn:requiredClasses to:referencedClassesWithReasons.
self addReferencesToClassesFromGlobalsInMethods:(self searchForExtensionsWithProject:self package) to:referencedClassesWithReasons.
+ self addReferencesToExtensionMethodsIn:requiredClasses to:referencedMethodsWithReasons.
"now map classes to packages and collect the reasons"
- packageExtractionBlock := [:classesWithReasons|
+ packageExtractionBlock :=
+ [:classesWithReasons|
|requiredPackageReasons|
requiredPackageReasons := Dictionary new.
classesWithReasons keysAndValuesDo:[:usedClass :reasonsPerClass|
@@ -6632,30 +6797,37 @@
requiredPackageReasons
].
- mandatoryPackages := packageExtractionBlock value:mandatoryClassesForLoadingWithReasons.
- referencedPackages := packageExtractionBlock value:referencedClassesWithReasons.
+ mandatoryPackageReasons := packageExtractionBlock value:mandatoryClassesForLoadingWithReasons.
+ referencedPackageReasons := packageExtractionBlock value:referencedClassesWithReasons.
+
+ "and map extension method invocations to packages and collect the reasons"
+ referencedMethodsWithReasons keysAndValuesDo:[:usedMethod :reasonsPerMethod |
+ (referencedPackageReasons at:usedMethod package ifAbsentPut:[OrderedSet new])
+ addAll:reasonsPerMethod
+ ].
ignoredPackages := Set
with:packageId
with:PackageId noProjectID.
- referencedPackages removeAllKeys:ignoredPackages ifAbsent:[].
+ referencedPackageReasons removeAllKeys:ignoredPackages ifAbsent:[].
"don't put classes from subProjects into the required list"
ignoredPackages addAll:(self siblingsAreSubProjects
ifTrue:[ self searchForSiblingProjects ]
ifFalse:[ self searchForSubProjects ]) asSet.
- mandatoryPackages removeAllKeys:ignoredPackages ifAbsent:[].
+ mandatoryPackageReasons removeAllKeys:ignoredPackages ifAbsent:[].
^ Array
- with:mandatoryPackages
- with:referencedPackages.
+ with:mandatoryPackageReasons
+ with:referencedPackageReasons.
"
self searchForPreRequisites:#'stx:libwidg3'
bosch_dapasx_Application searchForPreRequisites
bosch_dapasx_pav_browser searchForPreRequisites
+ self searchForPreRequisites:#'stx:goodies/json' withSubProjects:false
"
"Modified: / 07-08-2006 / 21:56:25 / fm"
@@ -7289,11 +7461,11 @@
!ProjectDefinition class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.447 2013-03-30 19:03:50 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.457 2013-04-16 16:11:50 stefan Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.447 2013-03-30 19:03:50 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ProjectDefinition.st,v 1.457 2013-04-16 16:11:50 stefan Exp $'
!
version_HG