"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
"{ Package: 'stx:libbasic' }"
Object subclass:#Project
instanceVariableNames:'name changeSet views directoryName properties packageName
repositoryDirectory repositoryModule overwrittenMethods
subProjects prerequisites isLoaded changedClasses'
classVariableNames:'CurrentProject SystemProject NextSequential AllProjects
LoadedProjects'
poolDictionaries:''
category:'System-Support'
!
Object subclass:#ClassInfo
instanceVariableNames:'conditionForInclusion className classFileName'
classVariableNames:''
poolDictionaries:''
privateIn:Project
!
Object subclass:#MethodInfo
instanceVariableNames:'conditionForInclusion methodName className fileName'
classVariableNames:''
poolDictionaries:''
privateIn:Project
!
!Project class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
this class is still under construction (especially the build features are unfinished).
Currently, all it does is keep track of per-project views
(to hide or show them), define the directory when filing-out,
and define packageNames for new classes and methods.
instance variables:
name <String> the name of this project, as shown
in a ProjectView
changeSet <ChangeSet> changes done, while this was the active project
views <Collection> views opened while this was the active project
directoryName <String> directory name, where fileOuts are done
properties
packageName <String> given to classes/methods which are created while
this is the active project
repositoryDirectory (default) name of the repository, when a new source containers are
created.
repositoryModule (default) name of the module, when new source containers are
created.
Future:
- keep track of per-project changes
- allow speficiation of the type of the project (application or library)
- allow building of whatever the target (as defined by the type) is
(this will allow build of class libs and apps by clicking a button)
- allow removal of project specific classes, methods etc.
[author:]
Claus Gittinger
"
! !
!Project class methodsFor:'initialization'!
initKnownProjects
"this is a temporary experimental kludge -
once the ProjectBrowser is finished, this info is read from
'.prj' files ..."
"/ collect project info while scanning all classes
"/ and methods ...
AllProjects isNil ifTrue:[
AllProjects := IdentitySet new.
].
AllProjects add:SystemProject.
AllProjects add:CurrentProject.
"/ Smalltalk allClassesDo:[:aClass |
"/ |packageID prj classFilename pkgInfo revInfo
"/ repositoryPath dir module lib nm|
"/
"/ aClass isMeta ifFalse:[
"/ (aClass isNamespace not or:[aClass == Smalltalk]) ifTrue:[
"/ (Smalltalk at:aClass name) == aClass ifFalse:[
"/ Transcript showCR:'skipping obsolete/removed class: ' , aClass name.
"/ ] ifTrue:[
"/ packageID := aClass package asSymbol.
"/ (packages includesKey:packageID) ifFalse:[
"/
"/ "/ a new one ...
"/
"/ prj := self new.
"/ prj package:packageID.
"/ prj directory:'???'.
"/ prj repositoryModule:'unknown'.
"/ prj repositoryDirectory:'unknown'.
"/
"/ nm := 'unknown'.
"/
"/ pkgInfo := aClass packageSourceCodeInfo.
"/ pkgInfo notNil ifTrue:[
"/ module := pkgInfo at:#module ifAbsent:nil.
"/ module notNil ifTrue:[
"/ prj repositoryModule:module
"/ ].
"/ dir := pkgInfo at:#directory ifAbsent:nil.
"/ dir notNil ifTrue:[
"/ prj repositoryDirectory:dir
"/ ].
"/ lib := pkgInfo at:#library ifAbsent:nil.
"/ lib notNil ifTrue:[
"/ prj type:#library.
"/ ].
"/ prj isLoaded:true.
"/ ].
"/
"/ nm := (module ? 'unknown')
"/ , ':'
"/ , (dir ? (lib ? 'unknown')).
"/
"/ prj name:nm.
"/ AllProjects add:prj.
"/ packages at:packageID put:prj.
"/ ] ifTrue:[
"/ prj := packages at:packageID.
"/ prj addClass:aClass.
"/ ].
"/ ].
"/ ].
"/ ].
"/ ].
"/
"/ Method allSubInstancesDo:[:aMethod |
"/ |packageID prj who mthdClass|
"/
"/ who := aMethod who.
"/ who notNil ifTrue:[ "/ skip unbound methods ...
"/ packageID := aMethod package asSymbol.
"/ (packages includesKey:packageID) ifFalse:[
"/ "/ a new one ...
"/ prj := self new.
"/ "/ prj name:libName.
"/ prj package:packageID.
"/ prj type:#library.
"/ prj directory:'???'.
"/ prj repositoryModule:'stx'.
"/ prj repositoryDirectory:'???'.
"/ prj isLoaded:true.
"/ AllProjects add:prj.
"/ packages at:packageID put:prj.
"/ ] ifTrue:[
"/ "/ see if the methods class is in the project;
"/ "/ if so, remove any patch-entry for this method.
"/ prj := packages at:packageID.
"/ ((prj classes includes:who methodClass)
"/ or:[prj classes includes:who methodClass name]) ifTrue:[
"/ prj removeMethod:aMethod.
"/ ]
"/ ]
"/ ]
"/ ].
"/
"/ "/ walk over binary modules, to find out directory names ...
"/
"/ ObjectFileLoader loadedObjectHandles do:[:h |
"/ |cls prj mDir|
"/
"/ cls := h classes firstIfEmpty:nil.
"/ cls notNil ifTrue:[
"/ prj := packages at:cls package ifAbsent:nil.
"/ prj notNil ifTrue:[
"/ mDir := h pathName asFilename directory pathName.
"/ prj directory = '???' ifTrue:[
"/ prj directory:mDir
"/ ] ifFalse:[
"/ prj directory ~= mDir ifTrue:[
"/ ('Project [warning]: conflicting project directories for ' , cls package) infoPrintCR.
"/ ]
"/ ]
"/ ]
"/ ].
"/ ].
"/
"/ self changed:#allProjects
"/ |stx p|
"/
"/ stx := self new name:'stx'.
"/ stx packageName:'noPackage'.
"/ stx changeSet:nil.
"/ stx type:#smalltalk.
"/ stx comment:'The ST/X project itself'.
"/
"/ AllProjects add:stx.
"/
"/ #(
"/ ('libbasic' #'stx:libbasic' 'Basic (non-GUI) classes. Required for all applications')
"/ ('libbasic2' #'stx:libbasic2' 'More basic (non-GUI) classes. Required for most applications')
"/ ('libbasic3' #'stx:libbasic3' 'More basic (non-GUI) classes. Required for development')
"/ ('libcomp' #'stx:libcomp' 'The bytecode compiler. Required for all applications')
"/ ('libview' #'stx:libview' 'Low level GUI classes. Required for all GUI applications')
"/ ('libview2' #'stx:libview2' 'Additional low level GUI classes. Required for most GUI applications')
"/ ('libwidg' #'stx:libwidg' 'Basic widgets. Required for all GUI applications')
"/ ('libwidg2' #'stx:libwidg2' 'More widgets. Required for most GUI applications')
"/ ('libwidg3' #'stx:libwidg3' 'More (fun) widgets. Seldom required')
"/ ('libtool' #'stx:libtool' 'Development applications. Required for program development')
"/ ('libtool2' #'stx:libtool2' 'More development applications. Required for GUI development')
"/ ('libui' #'stx:libui' 'UI spec classes. Required for UIPainter applications')
"/ ('libhtml' #'stx:libhtml' 'HTML related classes. Required for Web applications and the HTML browser')
"/ ('libodbc' #'stx:libodbc' 'ODBC interface classes.')
"/ ('libopengl' #'stx:libopengl' 'OpenGL interface classes.')
"/ ('persistency' #'stx:goodies/persistency' 'Simple DB interface')
"/ ('goodies' #'stx:goodies' 'Misc goodies - not really maintained')
"/ ) do:[:entry |
"/ |libName package comment|
"/
"/ libName := entry at:1.
"/ package := entry at:2.
"/ comment := entry at:3.
"/
"/ p := self new name:libName.
"/ p packageName:package.
"/ p type:#library.
"/ p comment:comment.
"/ stx addSubProject:p.
"/ ].
"
AllProjects := nil.
self initKnownProjects
"
"Modified: / 16.10.1999 / 13:10:37 / cg"
!
initialize
SystemProject isNil ifTrue:[
self initializeSystemProject.
].
CurrentProject := SystemProject.
AllProjects := nil.
self initKnownProjects.
"
SystemProject := nil.
Project initialize
"
!
initializeSystemProject
NextSequential := 1.
SystemProject := self new name:'default'.
"/ SystemProject package:(OperatingSystem getLoginName , ':NoProject') asSymbol.
SystemProject package:#'__NoProject__'.
SystemProject defaultNameSpace:Smalltalk.
SystemProject comment:'A default (dummy) project.
Is used as the current project in case no real project is ever activated.
Please do never save/checkin this project; instead, move classes & methods
into a concrete, real project and save that one in regular intervals.
Use this as a `scratch project''.
'.
"/ no longer - changes are always remembered in some project
false ifTrue:[
"
the SystemProject does not keep a record if changes,
but instead depends on the changes file - recording anything there.
"
SystemProject changeSet:nil.
].
ChangeSet notNil ifTrue:[
SystemProject changeSet:ChangeSet new
].
self changed:#defaultProject
!
reinitKnownProjects
"rescan the image for projects"
AllProjects := nil.
self initKnownProjects
! !
!Project class methodsFor:'instance creation'!
new
^ self basicNew initialize
! !
!Project class methodsFor:'accessing'!
addKnownProject:aProject
|allProjects|
allProjects := self knownProjects.
(allProjects detect:[:p | p package = aProject package] ifNone:nil) notNil ifTrue:[
self warn:'Project for ' , aProject package , ' is already present.'.
^ self.
].
AllProjects add:aProject.
self changed:#allProjects
!
addLoadedProject:aProject
aProject isLoaded:true.
self addKnownProject:aProject.
!
current
"return the currently active project"
CurrentProject isNil ifTrue:[CurrentProject := SystemProject ].
^ CurrentProject
"
Project current
"
!
current:aProject
"set the currently active project"
|prevProject|
prevProject := CurrentProject.
CurrentProject := aProject.
prevProject notNil ifTrue:[
self changed:#currentProject
].
!
currentPackageName
CurrentProject notNil ifTrue:[
^ CurrentProject package
].
^ nil
"
Project currentPackageName
"
!
defaultProject
"return the SystemDefault project"
^ SystemProject.
"
Project defaultProject package
"
!
knownProjects
AllProjects isNil ifTrue:[
self initKnownProjects
].
^ AllProjects ? #()
!
loadedProjects
^ self knownProjects select:[:p | p isLoaded]
!
projectNamed:aProjectName
"retrieve the named project; return nil if not known"
^ self knownProjects detect:[:p | p name = aProjectName] ifNone:nil.
"
Project projectNamed:'stx'
Project projectNamed:'default'
"
!
projectWithId:aPackageId
"retrieve the project with a particular id; return nil if not known"
^ self knownProjects detect:[:p | p package = aPackageId] ifNone:nil.
"
Project projectWithId:#'stx:libbasic'
Project projectWithId:'__NoProject__'
"
!
setDefaultProject
"set the currently active project to be the SystemDEfault project"
self current:SystemProject.
!
setProject:aProjectOrNil
"set the currently active project without updating others"
CurrentProject := aProjectOrNil.
"Created: 7.2.1996 / 14:00:45 / cg"
"Modified: 7.2.1996 / 14:01:16 / cg"
! !
!Project class methodsFor:'changes management'!
addClassCommentChangeFor:aClass
"add a comment-change for aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addClassCommentChangeFor:aClass
]
!
addClassDefinitionChangeFor:aClass
"add a class-def-change for aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addClassDefinitionChangeFor:aClass
]
"Created: 3.12.1995 / 13:44:58 / cg"
"Modified: 3.12.1995 / 13:58:04 / cg"
!
addClassRemoveChange:oldClass
"add a class-remove-change to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addClassRemoveChange:oldClass
]
!
addClassRenameChangeFrom:oldName to:newName
"add a class-rename-change to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addClassRenameChangeFrom:oldName to:newName
]
!
addDoIt:aString
"add a doIt to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addDoIt:aString
]
"Created: 3.12.1995 / 13:44:58 / cg"
"Modified: 3.12.1995 / 13:58:04 / cg"
!
addInstVarDefinitionChangeFor:aClass
"add an instvar-change for aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addInstVarDefinitionChangeFor:aClass
]
"Created: 3.12.1995 / 13:44:58 / cg"
"Modified: 3.12.1995 / 13:58:04 / cg"
!
addMethodCategoryChange:aMethod category:newCategory in:aClass
"add a method-category-change for aMethod in aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addMethodCategoryChange:aMethod category:newCategory in:aClass
]
!
addMethodChange:aMethod fromOld:oldMethod in:aClass
"add a method change in aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addMethodChange:aMethod fromOld:oldMethod in:aClass
].
!
addMethodChange:aMethod in:aClass
"add a method change in aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addMethodChange:aMethod in:aClass
].
!
addMethodPrivacyChange:aMethod in:aClass
"add a privacy change for aMethod in aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addMethodPrivacyChange:aMethod in:aClass
]
"Modified: 27.8.1995 / 22:48:17 / claus"
!
addPrimitiveDefinitionsChangeFor:aClass
"add a primitiveDef change for aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addPrimitiveDefinitionsChangeFor:aClass
]
!
addPrimitiveFunctionsChangeFor:aClass
"add a primitiveFuncs change for aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addPrimitiveFunctionsChangeFor:aClass
]
!
addPrimitiveVariablesChangeFor:aClass
"add a primitiveVars change for aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addPrimitiveVariablesChangeFor:aClass
]
!
addRemoveSelectorChange:aSelector fromOld:oldMethod in:aClass
"add a method-remove change in aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addRemoveSelectorChange:aSelector fromOld:oldMethod in:aClass
]
"Created: / 16.2.1998 / 12:45:10 / cg"
!
addRenameCategoryChangeIn:aClass from:oldCategory to:newCategory
"add a category rename change for aClass to the current project"
|p|
p := CurrentProject.
p notNil ifTrue:[
p addRenameCategoryChangeIn:aClass from:oldCategory to:newCategory
]
"Created: / 6.2.2000 / 02:27:35 / cg"
!
currentProjectDirectory
"return the name of the directory to use for fileOut.
The returned name already includes a file-separator at the end,
so the filename can be concatenated to it."
|p dirName|
p := CurrentProject.
p notNil ifTrue:[
dirName := p directory
] ifFalse:[
dirName := Filename currentDirectory name
].
^ dirName
"Modified: 7.9.1997 / 23:52:25 / cg"
!
rememberOverwrittenMethod:newMethod from:oldMethod
"remember a method (from another package) being overwritten.
This is only remembered, if the current project is not the
system project (to avoid filling this remembered-table)"
|p|
p := CurrentProject.
(p notNil
and:[p ~~ SystemProject]) ifTrue:[
p rememberOverwrittenMethod:newMethod from:oldMethod
] ifFalse:[
"/ 'Project [info]: DefaultProject does not remember overwritten methods' infoPrintCR
]
"Modified: / 7.3.1998 / 13:38:39 / cg"
! !
!Project class methodsFor:'misc'!
projectFileFormatVersion
^ 1
! !
!Project class methodsFor:'testing'!
isClassChanged:aClass
"return true, if aClass has been changed"
^self current changedClasses includesIdentical:aClass
! !
!Project methodsFor:'accessing'!
addPrerequisitePackage:aPackageId
"add onother prerequisitePackage to the project"
|list|
list := self prerequisites.
(list includes:aPackageId) ifFalse:[
list addLast:aPackageId
].
!
addSubProject:aProject
"add a subproject - obsolete; we use prerequisites now"
subProjects isNil ifTrue:[
subProjects := OrderedCollection new.
].
subProjects add:aProject
!
changeSet
"return the set of changes made in this project"
changeSet isNil ifTrue:[
"/
"/ for tiny-configurations, allow ChangeSet to be absent
"/
ChangeSet notNil ifTrue:[
changeSet := ChangeSet new.
].
].
^ changeSet
"Modified: 27.1.1997 / 11:58:36 / cg"
!
changeSet:aChangeSet
"set the set of changes made in this project - dangerous, you may loose
the actual changeSet."
changeSet := aChangeSet
"Modified: 27.1.1997 / 11:59:02 / cg"
!
changedClasses
changedClasses isNil ifTrue:[changedClasses := IdentitySet new].
^ changedClasses
"
self new changedClasses
"
!
defaultNameSpace
"return the defaultNameSpace of this project.
New classes will (if not specified by a directive) be installed
in this nameSpace. Useful, when filing in ST-80 code, to avoid
overwriting of standard classes."
^ (self propertyAt:#defaultNameSpace) ? Smalltalk
!
defaultNameSpace:aNamespace
"set the defaultNameSpace of this project.
New classes will (if not specified by a directive) be installed
in this nameSpace. Useful, when filing in ST-80 code, to avoid
overwriting of standard classes."
|prevDefault|
prevDefault := self defaultNameSpace.
aNamespace ~~ prevDefault ifTrue:[
self propertyAt:#defaultNameSpace put:aNamespace.
self changed:#defaultNameSpace.
self == CurrentProject ifTrue:[
Project changed:#defaultNameSpace
]
]
"Created: 2.1.1997 / 19:54:37 / cg"
"Modified: 27.1.1997 / 12:00:01 / cg"
!
directory
"return the projects directory.
If not specified, a fileOut will be done into that directory"
directoryName isNil ifTrue:[^ '.'].
^ directoryName
"Modified: 27.1.1997 / 12:00:41 / cg"
!
directory:aDirectoryName
"set the projects directory.
If not specified, a fileOut will be done into that directory"
directoryName := aDirectoryName.
self changed:#directory.
self == CurrentProject ifTrue:[
Project changed:#directory
]
"Modified: 27.1.1997 / 12:00:47 / cg"
!
isLoaded:aBoolean
isLoaded := aBoolean
!
libraryName
"return the projects library name.
This is the name of a classLibrary, created from this project"
|nm|
nm := self name.
^ nm copyFrom:(nm lastIndexOfAny:':/')+1
"/ ^ (self name copyReplaceAll:$/ with:$_) replaceAll:$: with:$_
!
name
"return the projects name.
This is for the user only - shown in the projectViews label"
^ name
"Modified: 27.1.1997 / 12:01:16 / cg"
!
name:aString
"set the projects name.
This is for the user only - shown in the projectViews label"
name := aString.
self changed:#name.
self == CurrentProject ifTrue:[
Project changed:#name
]
"Modified: 27.1.1997 / 12:01:09 / cg"
!
overwrittenMethods
"return the set of methods which were overwritten in this project.
This information allows uninstalling, by switching back to the
original methods."
^ overwrittenMethods
"Created: 27.1.1997 / 11:57:21 / cg"
"Modified: 27.1.1997 / 12:09:14 / cg"
!
package
"return the projects package identifier.
This identifier marks all methods and new classes which were created
in this project."
^ packageName
"Modified: 27.1.1997 / 12:10:00 / cg"
!
package:aPackageId
"set the projects package identifier.
This identifier marks all methods and new classes which were created
in this project."
packageName := aPackageId
"Modified: 27.1.1997 / 12:10:00 / cg"
!
packageName:aPackageId
"set the projects package identifier.
This identifier marks all methods and new classes which were created
in this project."
self package:aPackageId
"Modified: 27.1.1997 / 12:10:00 / cg"
!
prerequisiteClasses
"return the prerequisiteClasses of the project"
^ (self propertyAt:#prerequisiteClasses) ? #()
!
prerequisiteClasses:aCollectionOfClassesOrClassNames
"set the prerequisiteClasses of the project"
^ self propertyAt:#prerequisiteClasses put:aCollectionOfClassesOrClassNames
"Modified: / 26.4.1999 / 23:33:44 / cg"
!
prerequisitePackages
"return the prerequisitePackages of the project"
^ self prerequisites
"Created: / 26.4.1999 / 23:33:22 / cg"
!
prerequisitePackages:aCollectionOfPackagesOrPackageNames
"set the prerequisitePackages of the project"
^ self prerequisites:aCollectionOfPackagesOrPackageNames
"Modified: / 26.4.1999 / 23:34:40 / cg"
!
prerequisites
"return the prerequisites of the project"
^ prerequisites ? #()
!
prerequisites:aCollectionOfProjects
"set the prerequisites of the project"
prerequisites := aCollectionOfProjects
!
repositoryDirectory
"return the projects default repository location.
This is offered initially, when classes are checked into the
source repository initially"
^ repositoryDirectory
"Created: 25.11.1995 / 18:04:51 / cg"
"Modified: 27.1.1997 / 12:13:35 / cg"
!
repositoryDirectory:aRelativePathName
"set the projects default repository location.
This will be offered initially, when classes are checked into the
source repository initially"
repositoryDirectory := aRelativePathName
"Created: 25.11.1995 / 18:05:06 / cg"
"Modified: 27.1.1997 / 12:13:28 / cg"
!
repositoryModule
"return the projects default repository module name.
This is offered initially, when classes are checked into the
source repository initially"
^ repositoryModule
"Created: 25.11.1995 / 18:04:51 / cg"
"Modified: 27.1.1997 / 12:13:50 / cg"
!
repositoryModule:aString
"set the projects default repository module name.
This is offered initially, when classes are checked into the
source repository initially"
repositoryModule := aString
"Created: 25.11.1995 / 18:05:06 / cg"
"Modified: 27.1.1997 / 12:13:57 / cg"
!
subProjects
"return the subprojects - obsolete; we use prerequisites now"
^ subProjects ? #()
!
views
"return a collection of views which were opened in this project"
^ views asArray
"Modified: 27.1.1997 / 12:14:18 / cg"
!
views:aSetOfViews
"set the collection of views which were opened in this project"
views := WeakIdentitySet withAll:aSetOfViews
"Modified: 27.1.1997 / 12:14:26 / cg"
! !
!Project methodsFor:'administration'!
removeClassesFromSystem
"remove the all of my classes & patches from the system"
self classInfo do:[:clsInfo |
|clsName cls|
clsName := clsInfo className.
clsName isSymbol ifTrue:[
cls := Smalltalk at:clsName.
cls notNil ifTrue:[
cls removeFromSystem.
].
] ifFalse:[
self halt
].
].
!
removeFromSystem
"remove the project and all of its classes & patches from the
system"
self removeClassesFromSystem.
AllProjects remove:self ifAbsent:nil.
! !
!Project methodsFor:'changes'!
addClassCommentChangeFor:aClass
"add a comment-change for aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addClassCommentChangeFor:aClass
].
self rememberChangedClass:aClass
!
addClassDefinitionChangeFor:aClass
"add a class-def-change for aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addClassDefinitionChangeFor:aClass
].
self rememberChangedClass:aClass
!
addClassRemoveChange:oldClass
"add a class-remove-change to the current project"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addClassRemoveChange:oldClass
].
!
addClassRenameChangeFrom:oldName to:newName
"add a class-rename-change to the current project"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addClassRenameChangeFrom:oldName to:newName
].
self rememberChangedClass:(Smalltalk at:newName)
!
addDoIt:aString
"add a doIt to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addDoIt:aString
].
!
addInstVarDefinitionChangeFor:aClass
"add an instvar-definition-change for aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addInstVarDefinitionChangeFor:aClass
].
self rememberChangedClass:aClass
!
addMethodCategoryChange:aMethod category:newCategory in:aClass
"add a method-category-change for aMethod in aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addMethodCategoryChange:aMethod category:newCategory in:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:25:34 / cg"
!
addMethodChange:aMethod fromOld:oldMethod in:aClass
"add a method change in aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addMethodChange:aMethod fromOld:oldMethod in:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:25:38 / cg"
!
addMethodChange:aMethod in:aClass
"add a method change in aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addMethodChange:aMethod in:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:25:44 / cg"
!
addMethodPrivacyChange:aMethod in:aClass
"add a privacy change for aMethod in aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addMethodPrivacyChange:aMethod in:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:25:49 / cg"
!
addPrimitiveDefinitionsChangeFor:aClass
"add a primitiveDef change for aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addPrimitiveDefinitionsChangeFor:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:25:53 / cg"
!
addPrimitiveFunctionsChangeFor:aClass
"add a primitiveFuncs change for aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addPrimitiveFunctionsChangeFor:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:26:05 / cg"
!
addPrimitiveVariablesChangeFor:aClass
"add a primitiveVars change for aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addPrimitiveVariablesChangeFor:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:26:08 / cg"
!
addRemoveSelectorChange:aSelector fromOld:oldMethod in:aClass
"add a method-remove change in aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addRemoveSelectorChange:aSelector fromOld:oldMethod in:aClass
].
self rememberChangedClass:aClass
"Modified: / 5.11.2001 / 16:26:11 / cg"
!
addRenameCategoryChangeIn:aClass from:oldCategory to:newCategory
"add a category rename change in aClass to the receivers changeSet"
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet addRenameCategoryChangeIn:aClass from:oldCategory to:newCategory
].
self rememberChangedClass:aClass
"Created: / 6.2.2000 / 02:28:07 / cg"
"Modified: / 5.11.2001 / 16:26:14 / cg"
!
condenseChangesForClassCheckin:aClass
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet condenseChangesForClass:aClass package:aClass package
].
"Modified: / 5.11.2001 / 16:24:18 / cg"
!
condenseChangesForClassFilein:aClass
#TODO.
"/ do not remove, if there are still methodChanges for other
"/ packages around
changedClasses := self changedClasses select:[:cls | |realClass|
realClass := cls theNonMetaclass.
realClass name ~= aClass name
].
"Modified: / 5.11.2001 / 16:45:56 / cg"
!
condenseChangesForExtensionsCheckInInPackage:package
|changeSet|
(changeSet := self changeSet) notNil ifTrue:[
changeSet condenseChangesForExtensionsInPackage:package
].
"Created: / 5.11.2001 / 17:07:45 / cg"
!
rememberChangedClass:aClass
|realClass|
realClass := aClass theNonMetaclass.
self changedClasses add:realClass.
changedClasses := changedClasses
select:[:aClass | aClass theNonMetaclass isObsolete not].
"Modified: / 16.11.2001 / 13:18:16 / cg"
!
rememberOverwrittenMethod:newMethod from:oldMethod
"this is sent whenever a method is installed, which overwrites
an existing method from a different package.
Allows previous methods to be reconstructed."
overwrittenMethods isNil ifTrue:[
overwrittenMethods := IdentityDictionary new.
].
overwrittenMethods at:newMethod put:oldMethod
"Created: 27.1.1997 / 11:52:01 / cg"
"Modified: 30.1.1997 / 21:10:51 / cg"
! !
!Project methodsFor:'initialization'!
initialize
|numString|
views := WeakIdentitySet new.
numString := NextSequential printString.
NextSequential := NextSequential + 1.
name := 'new Project-' , numString.
packageName := 'private-' , numString.
self directory:'.'.
self repositoryModule:(OperatingSystem getLoginName).
self repositoryDirectory:'private'
"Created: 25.11.1995 / 18:05:44 / cg"
"Modified: 3.1.1997 / 13:24:10 / cg"
! !
!Project methodsFor:'load & save'!
conditionForAutoloadIsTrue:cond
"check condition ..."
^ cond == #autoload
!
conditionForInclusionIsTrue:cond
"check condition ..."
cond == #always ifTrue:[^ true].
cond == #autoload ifTrue:[^ true].
cond == #never ifTrue:[^ false].
cond == #unix ifTrue:[
^ OperatingSystem isUNIXlike
].
cond == #win32 ifTrue:[
^ OperatingSystem isMSWINDOWSlike
].
cond == #vms ifTrue:[
^ OperatingSystem isVMSlike
].
cond == #macos ifTrue:[
^ OperatingSystem isMAClike
].
self halt:'bad condition'
!
loadClassesFromProjectDirectory
"load my classes into the system.
The classes are loaded from the directory as defined by my
directory insTvar"
|myDirectory firstTrip|
myDirectory := self directory asFilename.
firstTrip := true.
"/ read twice; if the load order was not correct,
"/ this will fix things (i.e. nil superclasses ...)
2 timesRepeat:[
self classInfo do:[:clsInfo |
|clsName clsFileNameString cls clsFilename
cond include asAutoload|
clsName := clsInfo className.
(clsName startsWith:'Smalltalk::') ifTrue:[
clsInfo className:(clsName := clsName copyFrom:'Smalltalk::' size + 1).
].
clsName := clsName asSymbol.
clsFileNameString := clsInfo classFileName.
clsFileNameString isNil ifTrue:[clsFileNameString := clsName , '.st'].
clsName isSymbol ifTrue:[
clsFilename := myDirectory construct:clsFileNameString.
cls := Smalltalk at:clsName.
(cls isNil or:[firstTrip]) ifTrue:[
"/ ok - really not yet loaded.
Transcript showCR:'loading ' , clsFilename pathName , ' ...'.
] ifFalse:[
Transcript showCR:'reloading ' , clsFilename pathName , ' ...'.
].
"/ check condition ...
cond := clsInfo conditionForInclusion.
(self conditionForInclusionIsTrue:cond) ifTrue:[
(self conditionForAutoloadIsTrue:cond) ifTrue:[
Smalltalk
installAutoloadedClassNamed:clsName
category:'autoloaded'
package:self package
revision:nil
] ifFalse:[
Error handle:[:ex |
self warn:'error during fileIn: ' , ex description
] do:[
Class packageQuerySignal answer:packageName do:[
Parser::UndefinedSuperclassError handle:[:ex |
firstTrip ifFalse:[
ex reject.
]
] do:[
clsFilename fileIn.
"/ Smalltalk fileIn:clsFilename
]
]
]
]
]
] ifFalse:[
self halt
].
].
firstTrip := false.
].
!
loadFromProjectFile:aFilename
"fill all of my attributes from a projects file (.prj-file)"
|f pack targetConditions s module dir formatVersion|
f := aFilename asFilename.
directoryName := f directory pathName.
self directory:(f directory pathName).
pack := ResourcePack fromFile:f baseName directory:directoryName.
formatVersion := pack at:'fileFormatVersion' ifAbsent:nil.
"/ convert the resourcePack ...
packageName := pack at:'package' ifAbsent:packageName.
repositoryModule := packageName upTo:$:.
repositoryDirectory := packageName restAfter:$:.
name := pack at:'name' ifAbsent:name.
self type:(pack at:'type' ifAbsent:#application) asSymbol.
module := pack at:'repository.module' ifAbsent:nil.
module notNil ifTrue:[
repositoryModule ~= module ifTrue:[
'Project [warning]: module does not correspond to packageId' infoPrintCR.
'Project [info]: this will be not supported in future versions' infoPrintCR.
].
repositoryModule := module.
dir := pack at:'repository.directory' ifAbsent:nil.
dir notNil ifTrue:[
repositoryDirectory ~= dir ifTrue:[
'Project [warning]: directory does not correspond to packageId' infoPrintCR.
'Project [info]: this will be not supported in future versions' infoPrintCR.
].
repositoryDirectory := dir.
]
].
prerequisites := pack at:'prerequisites' ifAbsent:#().
self prerequisiteClasses:(pack at:'prerequisiteClasses' ifAbsent:#()).
s := pack at:'nameSpace' ifAbsent:nil.
s notNil ifTrue:[
self defaultNameSpace:(NameSpace name:s asSymbol).
].
subProjects := pack at:'subProjects' ifAbsent:subProjects.
(s := pack at:'comment' ifAbsent:nil) notNil ifTrue:[
self comment:s
].
"/ first, all of the conditions ...
targetConditions := Dictionary new.
pack keysAndValuesDo:[:key :val |
|conditionKey|
(key startsWith:'target.condition.') ifTrue:[
conditionKey := key copyFrom:'target.condition.' size + 1.
targetConditions at:conditionKey put:val.
]
].
properties isNil ifTrue:[
properties := IdentityDictionary new
].
properties at:#targetconditions put:targetConditions.
properties declare:#sourcesDirectory from:pack.
properties declare:#methodsFile from:pack.
properties declare:#files from:pack.
"/ fetch class info
"/
"/ each entry consist of:
"/ full-name-of-class
"/ condition (optional) - #unix / #win32 / #vms / #macos / #always / #never / #autoload
"/ fileName (optional)
properties at:#autoIncludeImageClasses put:false.
(pack at:'classes' default:#()) do:[:info |
|condKey className optionalFileName|
condKey := #always.
info isSymbol ifTrue:[
className := info.
] ifFalse:[
className := info at:1.
formatVersion == 0 ifTrue:[
info size > 1 ifTrue:[
optionalFileName := info at:2.
info size > 2 ifTrue:[
condKey := info at:3.
]
].
] ifFalse:[
className := info at:1.
info size > 1 ifTrue:[
condKey := info at:2.
info size > 2 ifTrue:[
optionalFileName := info at:3.
]
].
].
].
self
addClass:className
conditionForInclusion:condKey
classFileName:optionalFileName
].
"/ fetch methods info
(pack at:'methods' default:#()) do:[:info |
|condKey className methodName optionalFileName|
condKey := #always.
className := info at:1.
methodName := info at:2.
info size > 2 ifTrue:[
optionalFileName := info at:3.
info size > 3 ifTrue:[
condKey := info at:4.
]
].
self
addMethod:methodName inClass:className
conditionForInclusion:condKey
fileName:optionalFileName
].
self wasLoadedFromFile:true.
"/ all remaining properties
pack keysAndValuesDo:[:key :val |
(key startsWith:'property.') ifTrue:[
self propertyAt:(key copyFrom:'property.' size+1) asSymbol put:val.
]
].
"
Project current saveAsProjectFile.
Project new loadFromProjectFile:'default.prj'
Project new loadFromProjectFile:'../../libbasic/libbasic.prj'
"
"Modified: / 26.4.1999 / 23:21:33 / cg"
!
saveAsProjectFile
"store all of my attributes into a projects file (.prj-file)
(in the project-directory and named as <projectName>.prj)"
|dir fn nm s|
dir := self directory asFilename.
nm := self libraryName.
fn := dir construct:nm.
fn := fn withSuffix:'prj'.
fn exists ifTrue:[
fn copyTo:(fn pathName , '.bak')
].
s := fn writeStream.
self saveAsProjectFileOn:s.
s close.
"
Project current saveAsProjectFile
"
"Modified: / 26.4.1999 / 22:53:38 / cg"
!
saveAsProjectFileOn:aStream
"save the project info in a format which is both usable for reload
and somehow readable for humans.
Actually, the format is the same as used for resources (i.e. key - value pairs)
and the code below could be much simpler - if there where no humans to read it ..."
|s coll first maxLen t defNS methodsFile classes packageId
moduleFromPackageId directoryFromPackageId|
packageId := self package.
packageId isNil ifTrue:[
'Project [warning]: no valid packageId - generating a default' infoPrintCR.
packageId := OperatingSystem getLoginName , ':private'.
] ifFalse:[
(packageId includes:$:) ifFalse:[
'Project [warning]: no module in packageId - generating a default' infoPrintCR.
packageId := OperatingSystem getLoginName , ':' , packageId.
]
].
moduleFromPackageId := packageId upTo:$:.
directoryFromPackageId := packageId restAfter:$:.
s := aStream.
s nextPutLine:'; $Header' , '$'; nextPutLine:';'.
s nextPutLine:'; Project saved ' , Smalltalk timeStamp; nextPutLine:';'.
s nextPutAll:'; Be careful when editing - do not corrupt the files syntax.
; Lines starting with a semicolon are comment lines.
; Lines ending with a backslash are concatenated with the following line.
; Entries are key-value pairs, separated by whitespace;
; the value is a smalltalk literal expression.
'.
s nextPutAll:'fileFormatVersion'; tab; nextPutLine:(self class projectFileFormatVersion printString).
s nextPutAll:'
;
; general:
;
'.
s nextPutAll:'comment'.
s tab. s nextPutLine:(self comment storeString).
s nextPutAll:'name'.
s tab. s nextPutLine:(name storeString).
s nextPutAll:'type'.
s tab. s nextPutLine:(self type storeString).
s nextPutAll:'package'.
s tab. s nextPutLine:(packageId storeString).
defNS := self defaultNameSpace.
(defNS notNil and:[defNS ~~ Smalltalk]) ifTrue:[
s nextPutAll:'nameSpace'.
s tab. s nextPutLine:(defNS name storeString).
] ifFalse:[
defNS := nil.
].
"/ skip if same as what the packageID implies;
"/ this will be enforced in future versions.
repositoryModule isNil ifTrue:[
repositoryModule := moduleFromPackageId.
].
repositoryDirectory isNil ifTrue:[
repositoryDirectory := directoryFromPackageId
].
(repositoryModule ~= moduleFromPackageId
or:[repositoryDirectory ~= directoryFromPackageId]) ifTrue:[
'Project [warning]: module/directory does not correspond to packageId' infoPrintCR.
'Project [info]: this will be not supported in future versions' infoPrintCR.
s nextPutAll:'
;
; repository:
;
'.
s nextPutAll:'repository.module'.
s tab. s nextPutLine:(repositoryModule ? 'private') storeString.
s nextPutAll:'repository.directory'.
s tab. s nextPutLine:(repositoryDirectory ? packageId) storeString.
s cr.
].
(t := properties at:#'sourcesDirectory' ifAbsent:nil) notNil ifTrue:[
s nextPutAll:'sources'.
s tab. s nextPutLine:(t storeString).
].
first := true.
properties keysAndValuesDo:[:key :val |
(#(
comment
wasLoadedFromFile
targetconditions
classes
classInfo
methodInfo
prerequisiteClasses
files
sourcesDirectory
methodsFile
type
defaultNameSpace
) includes:key) ifFalse:[
first ifTrue:[
first := false.
s nextPutAll:'
;
; properties:
;
'.
].
s nextPutAll:'property.'; nextPutAll:key.
s tab.
key == #defaultNameSpace ifTrue:[
s nextPutLine:val name storeString.
] ifFalse:[
s nextPutLine:val storeString.
]
]
].
s nextPutAll:'
;
; sub-projects:
;
'.
s nextPutAll:'subProjects'; tab.
coll := self subProjects.
coll size = 0 ifTrue:[
s nextPutLine:'#()'.
] ifFalse:[
s nextPutLine:'#( \'.
coll do:[:aProjectOrProjectNameList |
|pName pPath|
aProjectOrProjectNameList isString ifTrue:[
pName := aProjectOrProjectNameList.
] ifFalse:[
aProjectOrProjectNameList isArray ifTrue:[
pName := aProjectOrProjectNameList at:1.
pPath := aProjectOrProjectNameList at:2.
] ifFalse:[
pName := aProjectOrProjectNameList name.
pPath := aProjectOrProjectNameList repositoryPath.
]
].
pPath isNil ifTrue:[
s tab. s nextPutAll:(pName storeString); nextPutLine:' \'.
] ifFalse:[
s tab. s nextPutAll:'( '.
s nextPutAll:(pName storeString); space;
nextPutAll:(pPath storeString); nextPutLine:') \'.
]
].
s nextPutLine:')'.
].
s nextPutAll:'
;
; required packages:
;
'.
s nextPutAll:'prerequisites'; tab.
coll := self prerequisites.
coll size = 0 ifTrue:[
s nextPutLine:'#()'.
] ifFalse:[
s nextPutLine:'#( \'.
coll do:[:aProjectOrProjectNameList |
|pName pPath|
aProjectOrProjectNameList isString ifTrue:[
pName := aProjectOrProjectNameList.
] ifFalse:[
aProjectOrProjectNameList isArray ifTrue:[
pName := aProjectOrProjectNameList at:1.
pPath := aProjectOrProjectNameList at:2.
] ifFalse:[
pName := aProjectOrProjectNameList name.
pPath := aProjectOrProjectNameList repositoryPath.
]
].
pPath isNil ifTrue:[
s tab. s nextPutAll:(pName storeString); nextPutLine:' \'.
] ifFalse:[
s tab. s nextPutAll:'( '.
s nextPutAll:(pName storeString); space;
nextPutAll:(pPath storeString); nextPutLine:') \'.
]
].
s nextPutLine:')'.
].
s nextPutAll:'
;
; required classes:
;
'.
s nextPutAll:'prerequisiteClasses'; tab.
coll := self prerequisiteClasses.
coll size = 0 ifTrue:[
s nextPutLine:'#()'.
] ifFalse:[
s nextPutLine:'#( \'.
coll do:[:aClassOrSymbol | |className|
(className := aClassOrSymbol) isSymbol ifFalse:[
className := aClassOrSymbol name
].
s tab. s nextPutAll:(className storeString); nextPutLine:' \'.
].
s nextPutLine:')'.
].
s nextPutAll:'
;
; classes:
; (for each class, one line of the form: ( #''className'' [condition [fileName]] )
; (where fileName and condition are optional)
;
'.
s nextPutAll:'classes'; tab.
classes := self classesInOrderFor:'save ''prj''-file.'.
classes isNil ifTrue:[^ self].
classes size = 0 ifTrue:[
s nextPutLine:'#()'.
] ifFalse:[
s nextPutLine:'#( \'.
"/ find the longest className (for layout only)
maxLen := classes inject:0 into:[:maxSoFar :aClassOrName |
|clsName|
aClassOrName isBehavior ifTrue:[
clsName := aClassOrName name.
] ifFalse:[
clsName := aClassOrName.
defNS notNil ifTrue:[
(clsName startsWith:(defNS name , '::')) ifFalse:[
clsName := (defNS name , '::' , clsName)
]
].
clsName := clsName asSymbol.
].
maxSoFar max:clsName storeString size
].
classes do:[:aClassOrName |
|clsInfo clsName fileName cond|
aClassOrName isBehavior ifTrue:[
clsName := aClassOrName name.
] ifFalse:[
clsName := aClassOrName.
defNS notNil ifTrue:[
(clsName startsWith:(defNS name , '::')) ifFalse:[
clsName := (defNS name , '::' , clsName)
]
].
clsName := clsName asSymbol.
].
clsInfo := self classInfoFor:clsName.
clsInfo isNil ifTrue:[
clsInfo := self classInfoFor:aClassOrName.
].
fileName := clsInfo classFileName.
fileName = (clsName , '.st') ifTrue:[
fileName := nil
].
cond := (clsInfo conditionForInclusion) ? #always.
s tab. s nextPutAll:'( ';
nextPutAll:(clsName storeString paddedTo:maxLen).
(cond ~~ #always or:[fileName notNil]) ifTrue:[
s tab; nextPutAll:cond storeString.
].
fileName notNil ifTrue:[
s tab; nextPutAll:fileName storeString.
].
s nextPutLine:') \'.
].
s nextPutLine:')'.
].
s nextPutAll:'
;
; methods (patches & extensions):
; (for each method, one line of the form: ( #''className'' #''methodName'' )
; (for metaclasses, #''name class'' is used)
; These are stored in the methodsFile (see below)
'.
s nextPutAll:'methods'; tab.
coll := self methodInfo.
coll size = 0 ifTrue:[
s nextPutLine:'#()'.
] ifFalse:[
s nextPutLine:'#( \'.
"/ find the longest className (for layout only)
maxLen := coll inject:0 into:[:maxSoFar :aMethodInfo |
|clsName|
clsName := aMethodInfo className.
maxSoFar max:clsName storeString size
].
coll do:[:aMethodInfo |
|clsName mthdName fileName cond|
clsName := aMethodInfo className.
mthdName := aMethodInfo methodName.
s tab. s nextPutAll:'( ';
nextPutAll:(clsName storeString paddedTo:maxLen);
tab; nextPutAll:mthdName storeString.
s nextPutLine:') \'.
].
s nextPutLine:')'.
].
methodsFile := properties at:#methodsFile ifAbsent:nil.
methodsFile size == 0 ifTrue:[
self methodInfo size > 0 ifTrue:[
'Project [warning]: no methodsFile defined - generating a default' infoPrintCR.
methodsFile := 'extensions.st'
]
].
methodsFile size > 0 ifTrue:[
s nextPutAll:'
;
; methods above are stored in:
;
'.
s nextPutAll:'methodsFile'; tab; nextPutLine:'''' , methodsFile , ''''.
].
s nextPutAll:'
;
; files (for deployment):
;
'.
s nextPutAll:'files'; tab.
coll := properties at:#'files' ifAbsent:#().
coll size = 0 ifTrue:[
s nextPutLine:'#()'.
] ifFalse:[
s nextPutLine:'#( \'.
coll do:[:aFileEntry |
s tab. s nextPutAll:(aFileEntry storeString); nextPutLine:' \'.
].
s nextPutLine:')'.
].
"
Project current saveOn:Transcript
"
"Modified: / 26.4.1999 / 23:24:12 / cg"
! !
!Project methodsFor:'maintenance'!
buildProject
"invoke 'make' in the project directory"
OperatingSystem executeCommand:('cd ' , self directory , ' ; make')
!
buildProjectWithOutputTo:aStream
"invoke 'make' in the project directory"
|p cmdOutStream cmdInStream readerProcess|
aStream notNil ifTrue:[
"/ need an external stream for that.
aStream isExternalStream ifTrue:[
cmdOutStream := aStream
] ifFalse:[
p := ExternalStream makePipe.
cmdOutStream := p at:2.
"/ start a reader process
readerProcess := [
|data|
cmdInStream := p at:1.
[cmdInStream atEnd] whileFalse:[
data := cmdInStream nextAvailable:512.
aStream nextPutAll:data.
]
] newProcess.
readerProcess name:'cmd output reader'.
readerProcess resume.
]
].
OperatingSystem
executeCommand:('cd ' , self directory , ' ; make')
inputFrom:nil
outputTo:cmdOutStream
errorTo:cmdOutStream
inDirectory:nil
onError:[:status| false].
readerProcess terminate.
cmdInStream close.
cmdOutStream close.
!
classesInOrderFor:whatMsg
|classesOrNames classes numBad firstBad msg|
classesOrNames := self classes.
numBad := 0.
firstBad := nil.
classes := classesOrNames collect:[:clsOrSymbol | |cls|
clsOrSymbol isBehavior ifFalse:[
cls := Smalltalk at:clsOrSymbol asSymbol.
cls isNil ifTrue:[
numBad := numBad + 1.
firstBad := firstBad ? clsOrSymbol.
] ifFalse:[
cls isLoaded ifFalse:[
cls := cls autoload.
cls isLoaded ifFalse:[
cls := nil
]
].
].
cls.
] ifTrue:[
clsOrSymbol
]
].
numBad ~~ 0 ifTrue:[
msg := 'Cannot determine load/compile order when about to ' , whatMsg.
msg := msg , '\Reason: Class ''' , firstBad allBold
, ''' is not loaded.'.
numBad ~~ 1 ifTrue:[
msg := msg , '\(' , (numBad-1) printString , ' more unloaded classes were found)'
].
msg := msg , '\\You will have to manually load the classes or edit the project file.'.
self warn:msg withCRs.
^ classesOrNames.
].
"/ to not list private classes
classes := classes select:[:cls | cls owningClass isNil].
classes := classes copy topologicalSort:[:a :b | b isSubclassOf:a].
^ classes
!
createAbbrevFile
"creates a 'abbrev.stc' file, for autoloading classes."
|d f out classes myPackage transcript notEmpty|
classes := self classesInOrderFor:'generate ''abbrev.stc''-file.'.
classes isNil ifTrue:[^ self].
notEmpty := (classes size > 0).
transcript := Transcript current.
transcript showCR:'creating abbrev.stc file'.
d := directoryName asFilename.
f := d construct:'abbrev.stc'.
[
out := f writeStream.
] on:FileStream openErrorSignal do:[:ex|
self warn:'cannot create abbrev.stc'.
^ self
].
myPackage := self package.
notEmpty ifTrue:[
classes do:[:cls |
|clsInfo cond fileName clsName clsCategory|
clsInfo := self classInfoFor:cls.
cond := clsInfo conditionForInclusion.
(cond == #always or:[cond == #autoload]) ifTrue:[
fileName := clsInfo classFileName.
fileName isNil ifTrue:[
cls isBehavior ifTrue:[
fileName := cls nameWithoutNameSpacePrefix
] ifFalse:[
fileName := cls
]
].
(fileName endsWith:'.st') ifTrue:[
fileName := fileName copyWithoutLast:3
].
cls isBehavior ifTrue:[
clsName := cls name.
clsCategory := cls category.
] ifFalse:[
clsName := cls.
clsCategory := 'unknown category'.
].
out nextPutAll:clsName.
out space.
out nextPutAll:fileName.
out space.
out nextPutAll:self package.
out space.
out nextPut:$'; nextPutAll:clsCategory; nextPut:$'.
out cr.
]
].
].
out close
!
createLoadAllFile
"creates a 'loadAll' file, which will load all classes
of the project - this loadAll file is supposed to be located
in the projects source directory."
|d f out classes transcript|
classes := self classesInOrderFor:'generate ''loadAll''-file.'.
classes isNil ifTrue:[^ self].
transcript := Transcript current.
transcript showCR:'creating loadAll file'.
d := directoryName asFilename.
f := d construct:'loadAll'.
f exists ifTrue:[
f renameTo:(d construct:'loadAll.bak')
].
[
out := f writeStream.
] on:FileStream openErrorSignal do:[:ex|
self warn:'cannot create loadAll'.
(d construct:'loadAll.bak') renameTo:f.
^ self
].
self createLoadAllFileOn:out.
out close
!
createLoadAllFileOn:outStream
"creates a 'loadAll' file, which will load all classes
of the project - this loadAll file is supposed to be located
in the projects source directory."
|in classes classInfo myPackage
methodsFile prerequisitePackages transcript notEmpty|
classes := self classesInOrderFor:'generate ''loadAll''-file.'.
classes isNil ifTrue:[^ self].
methodsFile := self propertyAt:#methodsFile.
notEmpty := (classes size > 0 or:[methodsFile size > 0]).
myPackage := self package.
outStream nextPutLine:'"/
"/ $' , 'Header' , '$'.
outStream nextPutLine:'"/
"/ loadAll-file to fileIn code for: ' , myPackage.
outStream nextPutAll:'"/
"/ Automatically generated from project definition.
"/ DO NOT MODIFY THIS fILE;
"/ modify the .prj file instead, and regenerate this file
"/ with the ProjectBrowser tool.
"/
"/
"/ Prerequisites:
"/'.
prerequisitePackages := self prerequisitePackages
collect:[:entry |
|pName|
entry isString ifTrue:[
pName := entry
] ifFalse:[
entry isArray ifTrue:[
pName := entry at:1
] ifFalse:[
pName := entry name
]
]
].
prerequisitePackages size == 0 ifTrue:[
outStream nextPutLine:''.
outStream nextPutLine:'"/ Smalltalk loadPackage:''module:directory''.'.
outStream nextPutLine:'"/ Smalltalk loadPackage:''....''.'.
] ifFalse:[
outStream cr.
prerequisitePackages do:[:packName |
outStream nextPutLine:'Smalltalk loadPackage:''' , packName , '''.'.
]
].
methodsFile := self propertyAt:#methodsFile.
notEmpty ifTrue:[
outStream nextPutAll:'!!
"{ package:''' , myPackage , ''' }"!!
|files|
''loading package ' , myPackage , ' ...'' infoPrintCR.
files := #(
'.
classes do:[:cls |
|clsInfo cond fileName|
clsInfo := self classInfoFor:cls.
cond := clsInfo conditionForInclusion.
(cond == #always or:[cond == #autoload]) ifTrue:[
outStream nextPutAll:' '''.
fileName := clsInfo classFileName.
fileName isNil ifTrue:[
cls isBehavior ifFalse:[
fileName := cls
] ifTrue:[
fileName := cls nameWithoutNameSpacePrefix
]
].
(fileName endsWith:'.st') ifFalse:[
fileName := fileName , '.st'
].
fileName printOn:outStream.
outStream nextPutAll:''''; cr.
]
].
methodsFile size > 0 ifTrue:[
outStream
nextPutAll:' ''';
nextPutAll:methodsFile;
nextPutAll:'''';
cr.
].
outStream nextPutAll:') asOrderedCollection.
"/ see if there is a classLibrary
(Smalltalk fileInClassLibrary:''' , self libraryName , ''') ifTrue:[
|handle loaded|
handle := ObjectFileLoader loadedObjectHandles
detect:[:h | h package = ''' , myPackage , '''] ifNone:nil.
handle ifNotNil:[
loaded := Set new:(handle classes size).
handle classes do:[:c| c isMeta ifFalse:[loaded add:c classFilename]].
'.
methodsFile size > 0 ifTrue:[
outStream nextPutLine:(' loaded add:''' , methodsFile , '''.').
].
outStream nextPutAll:' files := files asOrderedCollection select:[:f| (loaded includes:f) not].
].
].
"/ load files which are not in the classLibrary (all if there is none)
files size > 0 ifTrue:[
files do:[:f |
''.'' infoPrint.
f asFilename exists ifTrue:[
Smalltalk fileIn:f.
] ifFalse:[
Smalltalk fileIn:(''source/'' , f)
]
].
'' '' infoPrintCR.
].
'' done (' , myPackage , ').'' infoPrintCR.
'.
].
!
createMacMakefile
"creates an mac-os makefile"
Transcript current showCR:'Mac support not yet implemented - no mac.mak created for Mac'.
!
createMakefile
"creates an initial Makefile from a Make.proto file.
Requires the stmkmf script"
|d top transcript stmkmf|
OperatingSystem isUNIXlike ifTrue:[
Transcript current showCR:'creating Makefile'.
d := directoryName asFilename pathName.
top := (d , '/' , (self findTopFrom:directoryName)) asFilename.
(top construct:'rules') exists ifFalse:[
self warn:'Could not execute stmkmf - no TOP/rules directory found.'
].
(stmkmf := ((top construct:'rules') construct:'stmkmf')) exists ifFalse:[
self warn:'Could not execute stmkmf - no TOP/rules/stmkmf found.'
].
transcript := Transcript current.
(OperatingSystem
executeCommand:('sh ' , stmkmf pathName)
outputTo:transcript
errorTo:transcript
inDirectory:d
) ifFalse:[
self warn:'Error executing stmkmf - no Makefile built.'
].
].
self createNTMakefile.
self createVMSMakefile.
self createMacMakefile.
"Modified: / 26.9.1999 / 16:18:29 / cg"
!
createNTMakefile
"creates an nt.mak makefile"
|d f s type appName topName classes methodsFile transcript|
classes := self classesInOrderFor:'generate ''nt.mak''-file.'.
classes isNil ifTrue:[^ self].
topName := self findTopFrom:directoryName.
transcript := Transcript current.
transcript showCR:'Generating make support for Win9x/WinNT...'.
transcript showCR:'creating bmake.bat'.
[
d := directoryName asFilename.
f := d construct:'bmake.bat'.
s := f writeStream.
s nextPutLine:'if not exist object\nul mkdir objbc'.
s nextPutLine:'make.exe -N -f nt.mak %1 %'.
s close.
transcript showCR:'creating bc.def'.
d := directoryName asFilename.
f := d construct:'bc.def'.
s := f writeStream.
s nextPutLine:'LIBRARY ' , self libraryName.
s nextPutLine:'DESCRIPTION ''AddOn library for ST/X''
CODE PRELOAD MOVEABLE DISCARDABLE
SEGMENTS
INITCODE PRELOAD SHARED DISCARDABLE
EXPORTS
__' , self libraryName , '_Init @1'.
s close.
transcript showCR:'creating nt.def'.
d := directoryName asFilename.
f := d construct:'nt.def'.
s := f writeStream.
s nextPutLine:'LIBRARY ' , self libraryName.
s nextPutLine:'DESCRIPTION ''AddOn library for ST/X''
CODE EXECUTE READ SHARED
DATA READ WRITE
SECTIONS
INITCODE READ EXECUTE SHARED
INITDATA READ WRITE
EXPORTS
_' , self libraryName , '_Init'.
s close.
transcript showCR:'creating libInit.cc'.
d := directoryName asFilename.
f := d construct:'libInit.cc'.
s := f writeStream.
s nextPutAll:'/*
* DO NOT EDIT
* automatically generated from project.prj
*/
#define __INDIRECTVMINITCALLS__
#include <stc.h>
#define INIT_TEXT_SECT /* as nothing */
#ifdef WIN32
# pragma codeseg INITCODE "INITCODE"
#else /* not WIN32 */
# if defined(__GNUC__)
# if (__GNUC__ == 2 && __GNUC_MINOR__ >= 7) || __GNUC__ > 2
# undef INIT_TEXT_SECT
# define INIT_TEXT_SECT __attribute__((section(".stxitext")))
# endif
# endif /* not GNUC */
#endif /* not WIN32 */
#ifdef INIT_TEXT_SECT
extern void _' , self libraryName , '_Init() INIT_TEXT_SECT;
#endif
void _' , self libraryName , '_Init(pass, __pRT__, snd)
OBJ snd; struct __vmData__ *__pRT__; {
__BEGIN_PACKAGE2__("' , self libraryName , '", _' , self libraryName , '_Init, "' , self package , '");
'.
classes notNil ifTrue:[
classes do:[:aClass |
|abbrev|
abbrev := Smalltalk fileNameForClass:aClass name.
s nextPutAll:'_'; nextPutAll:abbrev; nextPutLine:'_Init(pass,__pRT__,snd);'.
].
].
s nextPutAll:'__END_PACKAGE__();
}
'.
s close.
transcript showCR:'creating nt.mak'.
d := directoryName asFilename.
f := d construct:'nt.mak'.
f exists ifTrue:[
f renameTo:(d construct:'nt.mak.bak')
].
s := f writeStream.
s nextPutAll:'# $' , 'Header'.
s nextPutLine:'$'.
s nextPutAll:'#
# -- nt.mak created from project at ' .
s nextPutAll:Smalltalk timeStamp.
s nextPutAll:'
#
# Warning: YOU SHOULD NOT MODIFY THIS FILE - MODIFY THE .prj FILE INSTEAD
# and let the ProjectBrowser recreate this file.
# once you modify this file, do not recreate nt.mak again
# - otherwise, your changes are lost.
# module and directory-in-module;
# these should correspond to the directory hierarchy
# location (otherwise, ST/X will have a hard time to
# find out the packages location from its packageID)
MODULE=' , self repositoryModule ? 'unknown' , '
MODULE_DIR=' , self repositoryDirectory ? 'unknown' , '
# default installation directory:
# (overwrite with ''make INSTALLTOP_DIR=... install'')
# the INSTALLBASE is imported from configurations... and usually
# defaults to something like /opt/smalltalk.
# (overwrite with ''make INSTALLBASE=... install'')
INSTALLTOP_DIR=$(INSTALLBASE)/packages/$(MODULE)/$(MODULE_DIR)
INSTALLLIB_DIR=$(INSTALLTOP_DIR)
INSTALLBIN_DIR=$(INSTALLTOP_DIR)
#
# position (of this package) in directory hierarchy:
# (must point to ST/X top directory, for tools and includes)
TOP=' , topName ,'
!!INCLUDE "$(TOP)\rules\stdHeader_nt"
# subdirectories where targets are to be made:
SUBDIRS=
# subdirectories where Makefiles are to be made:
# (only define if different from SUBDIRS)
# ALLSUBDIRS=
# the name of your classLibrary:
# ********** REQUIRED: CHECK the next line ***
LIBNAME=' , self libraryName , '
#### LIB_BASE =0x05000000
# the next define suppresses installation of
# the classes as autoloaded (i.e. not added to abbrev.stc).
SUPPRESS_LOCAL_ABBREVS=1
# the package is stored as an ID in classes and methods
# to identify code belonging to this project.
# It also specifies the position in the source repository
# and directory tree, when packages are loaded by packageID.
# ********** REQUIRED: CHECK the next line ***
PACKAGE=$(MODULE):$(MODULE_DIR)
# Argument(s) to the stc compiler.
# -H. : create header files locally
# (if removed, they will be created as common
# -Pxxx : defines the package
# -Zxxx : a prefix for variables within the classLib
# -Dxxx : defines passed to to CC for inline C-code
# -Ixxx : include path passed to CC for inline C-code
# +optspace : optimized for space
# +optspace2 : optimized more for space
# +optspace3 : optimized even more for space
# +optinline : generate inline code for some ST constructs
# +inlineNew : additionally inline new
# +inlineMath : additionally inline some floatPnt math stuff
#
# ********** OPTIONAL: MODIFY the next line(s) ***
# STCLOCALOPTIMIZATIONS=+optinline +inlineNew
# STCLOCALOPTIMIZATIONS=+optspace3
STCLOCALOPTIMIZATIONS=+optspace3
# Argument(s) to the stc compiler.
# -warn : no warnings
# -warnNonStandard : no warnings about ST/X extensions
# -warnEOLComments : no warnings about EOL comment extension
# -warnPrivacy : no warnings about privateClass extension
#
# ********** OPTIONAL: MODIFY the next line(s) ***
# STCWARNINGS=-warn
# STCWARNINGS=-warnNonStandard
# STCWARNINGS=-warnEOLComments
STCWARNINGS='.
(self propertyAt:#'make.stc.warnEOLComments') == false ifTrue:[
s nextPutAll:'-warnEOLComments '.
].
(self propertyAt:#'make.stc.warnNonStandard') == false ifTrue:[
s nextPutAll:'-warnNonStandard '.
].
s nextPutAll:((self propertyAt:#'make.stc.WARNINGOPTIONS') ? '') , '
# if your embedded C code requires any system includes,
# add the path(es) here:,
# ********** OPTIONAL: MODIFY the next lines ***
# LOCALINCLUDES=-Ifoo -Ibar
LOCALINCLUDES=' , ((self propertyAt:#'make.stc.LOCALINCLUDES') ? '') , '
# if you need any additional defines for embedded C code,
# add them here:,
# ********** OPTIONAL: MODIFY the next lines ***
# LOCALDEFINES=-Dfoo -Dbar -DDEBUG
LOCALDEFINES=' , ((self propertyAt:#'make.stc.LOCALDEFINES') ? '') , '
STCLOCALOPT=-I. $(STCLOCALOPTIMIZATIONS) $(STCWARNINGS) $(LOCALINCLUDES) $(LOCALDEFINES) -H. -package=$(PACKAGE) -varPrefix=$(LIBNAME) $(COMMONSYMFLAG) $(INITCODESEPFLAG)
# ********** OPTIONAL: MODIFY the next line ***
# additional C-libraries that should be pre-linked with the class-objects
LD_OBJ_LIBS=' , ((self propertyAt:#'make.LD_OBJ_LIBS') ? '') , '
# ********** OPTIONAL: MODIFY the next line ***
# additional C targets or libraries should be added below
LOCAL_EXTRA_TARGETS=' , ((self propertyAt:#'make.LOCAL_EXTRA_TARGETS') ? '') , '
#ALL:: preMake $(LIBDIR)\$(LIBNAME).lib $(BINDIR)\$(LIBNAME).dll postMake
ALL:: $(LIBDIR)\$(LIBNAME).lib $(BINDIR)\$(LIBNAME).dll
'.
"/ type := #library.
"/ appName := 'app'.
"/ libName := 'lib'.
"/ startUpClass := 'Smalltalk'.
"/ startUpSelector := 'start'.
"/
"/ properties notNil ifTrue:[
"/ type := properties at:#projectType ifAbsent:type.
"/ appName := properties at:#applicationName ifAbsent:appName.
"/ startUpClass := properties at:#startupClass ifAbsent:startUpClass.
"/ startUpSelector := properties at:#startupSelector ifAbsent:startUpSelector.
"/ ].
"/
"/ s nextPutAll:'#
"/# define the name of the library to create
"/#
"/'.
"/ s nextPutAll:'LIBNAME=lib' , appName; cr; cr.
"/
"/ s nextPutAll:'#
"/# the target rule:
"/#
"/all:: abbrev.stc objs genClassList $(OBJTARGET)
"/
"/'.
"/
"/ type == #executable ifTrue:[
"/ s nextPutAll:'PROGS = ' , appName; cr.
"/ s nextPutAll:('STARTUP_CLASS=' , startUpClass); cr.
"/ s nextPutAll:'STARTUP_SELECTOR="' , startUpSelector; nextPutAll:'"'; cr.
"/ ].
"/
"/ s nextPutAll:'#
"/# define the object files that are to be created
"/#
"/'.
s nextPutAll:'OBJS='.
classes do:[:aClass |
|fileName clsInfo cond include|
clsInfo := self classInfoFor:aClass.
include := true.
clsInfo notNil ifTrue:[
cond := clsInfo conditionForInclusion.
(self conditionForInclusionIsTrue:cond) ifFalse:[
include := false.
] ifTrue:[
(self conditionForAutoloadIsTrue:cond) ifTrue:[
include := false
]
].
].
include ifTrue:[
s nextPutAll:' \'. s cr.
fileName := clsInfo classFileName.
fileName isNil ifTrue:[
fileName := Smalltalk fileNameForClass:aClass name.
].
fileName := fileName asFilename withoutSuffix name.
s nextPutAll:' $(OUTDIR)'; nextPutAll:fileName; nextPutAll:'.$(O)'.
]
].
(methodsFile := self propertyAt:#methodsFile) size > 0 ifTrue:[
s nextPutAll:' \'. s cr.
s nextPutAll:' $(OUTDIR)';
nextPutAll:(methodsFile asFilename withoutSuffix baseName);
nextPutAll:'.$(O)'.
].
s cr.
s nextPutAll:'
# add more install actions here
install:
# add more install actions for aux-files (resources) here
installAux:
# add more preMake actions here
preMake:
# add more postMake actions here
postMake: cleanjunk
#clean::
#' , Character tab , '-del $(OUTDIR)*.obj
#' , Character tab , '-del *.sc
#clobber::
#' , Character tab , '-del $(OUTDIR)*.obj
#' , Character tab , '-del *.sc
#' , Character tab , '-del *.dll
#' , Character tab , '-del *.lib
!!INCLUDE $(TOP)\rules\stdRules_nt
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
'.
classes notNil ifTrue:[
classes do:[:aClass |
|fileName clsInfo|
clsInfo := self classInfoFor:aClass.
fileName := clsInfo classFileName.
fileName isNil ifTrue:[
fileName := Smalltalk fileNameForClass:aClass name.
].
fileName := fileName asFilename withoutSuffix name.
s nextPutAll:'$(OUTDIR)'; nextPutAll:fileName; nextPutAll:'.$(O): '.
s nextPutAll:fileName; nextPutAll:'.st '.
"/ aClass allSuperclassesDo:[:superClass|
"/ s nextPutAll:(Smalltalk fileNameForClass:superClass name) , '.$(H) '.
"/ ].
s nextPutAll:'$(STCHDR)'; cr.
].
].
s nextPutAll:'# ENDMAKEDEPEND --- do not remove this line'.
s cr; cr.
type == #executable ifTrue:[
s nextPutAll:'ALL:: $(PROGS)'; cr.
s nextPutAll:appName.
s nextPutAll:':: main.$(O) classList.$(O) $(OBJS)'; cr.
s tab; nextPutAll:'$(LD) $(ST_LDFLAG) $(LDFLAGS) -o ';
nextPutAll:appName;
nextPutAll:' \'; cr.
s tab; tab; nextPutAll:'$(CRT0) main.$(O) classList.$(O) $(OBJS) $(EXTRA_OBJ) $(LIBOBJS) \'; cr.
s tab; tab; nextPutAll:'$(LIBRUNDIR)/hidata.o $(LIBRUN) \'; cr.
s tab; tab; nextPutAll:'$(MATHLIB) $(EXTRALIBS) -lXext $(SYSLIBS) $(OTHERLIBS) $(CRTN)'; cr.
].
s close
] on:FileStream openErrorSignal do:[:ex|
self warn:'cannot create ', ex parameter printString.
]
"Modified: / 19.1.2000 / 16:55:34 / cg"
!
createProjectFiles
"actually, creates all files to do a make in the project directory"
directoryName asFilename exists ifFalse:[
(self confirm:'create new projectDirectory: ' , directoryName)
ifFalse:[^ self].
OperatingSystem recursiveCreateDirectory:directoryName.
].
self createMakefile.
self createSourcefiles.
self createProtoMakefile.
(self propertyAt:#deliverLoadAllFile) == true ifTrue:[
self createLoadAllFile
].
!
createProtoMakefile
"creates a Make.proto file"
|d f s type appName
topName classes methodsFile notEmpty repositoryModule repositoryDirectory pkg|
classes := self classesInOrderFor:'generate ''Make.proto''-file.'.
classes isNil ifTrue:[^ self].
methodsFile := self propertyAt:#methodsFile.
notEmpty := (classes size > 0 or:[methodsFile size > 0]).
topName := self findTopFrom:directoryName.
repositoryModule := self repositoryModule ? 'unknown'.
repositoryDirectory := self repositoryDirectory ? 'unknown'.
pkg := repositoryModule , ':' , repositoryDirectory.
Transcript current showCR:'creating Make.proto'.
d := directoryName asFilename.
f := d construct:'Make.proto'.
f exists ifTrue:[
f renameTo:(d construct:'Make.proto.bak')
].
[
s := f writeStream.
] on:FileStream openErrorSignal do:[:ex|
self warn:'cannot create prototype Makefile'.
^ self
].
s nextPutAll:'# $' , 'Header'.
s nextPutLine:'$'.
s nextPutAll:'#
# -- Make.proto created from project at ' .
s nextPutAll:Smalltalk timeStamp.
s nextPutAll:'
#
# Warning: YOU SHOULD NOT MODIFY THIS FILE - MODIFY THE .prj FILE INSTEAD
# and let the ProjectBrowser recreate this file.
# once you modify this file, do not rerun
# stmkmp or recreate the Make.proto again - otherwise, your changes are lost.
# module and directory-in-module;
# these should correspond to the directory hierarchy
# location (otherwise, ST/X will have a hard time to
# find out the packages location from its packageID)
MODULE=' , repositoryModule , '
MODULE_DIR=' , repositoryDirectory , '
'.
s nextPutAll:'
# default installation directory:
# (overwrite with ''make INSTALLTOP_DIR=... install'')
# the INSTALLBASE is imported from configurations... and usually
# defaults to something like /opt/smalltalk.
# (overwrite with ''make INSTALLBASE=... install'')
INSTALLTOP_DIR=$(INSTALLBASE)/packages/$(MODULE)/$(MODULE_DIR)
INSTALLLIB_DIR=$(INSTALLTOP_DIR)
INSTALLBIN_DIR=$(INSTALLTOP_DIR)
'.
s nextPutAll:'
#
# position (of this package) in directory hierarchy:
# (must point to ST/X top directory, for tools and includes)
TOP=' , topName ,'
# subdirectories where targets are to be made:
SUBDIRS='.
self prerequisitePackages do:[:aPackageId |
|p|
"/ add sub-packages only
(aPackageId startsWith:pkg) ifTrue:[
p := aPackageId copyFrom:pkg size + 1.
(p startsWith:$/) ifTrue:[
p := p copyFrom:2
].
s nextPutAll:p.
s space.
]
].
s nextPutAll:'
# subdirectories where Makefiles are to be made:
# (only define if different from SUBDIRS)
# ALLSUBDIRS=
'.
notEmpty ifTrue:[
s nextPutAll:'
# the name of your classLibrary:
# ********** REQUIRED: CHECK the next line ***
LIBNAME=' , self libraryName , '
'.
].
false ifTrue:[
s nextPutAll:'
# the next define suppresses installation of
# the classes as autoloaded (i.e. not added to abbrev.stc).
SUPPRESS_LOCAL_ABBREVS=1
'.
].
s nextPutAll:'
# the package is stored as an ID in classes and methods
# to identify code belonging to this project.
# It also specifies the position in the source repository
# and directory tree, when packages are loaded by packageID.
# ********** REQUIRED: CHECK the next line ***
PACKAGE=$(MODULE):$(MODULE_DIR)
# Argument(s) to the stc compiler.
# -H. : create header files locally
# (if removed, they will be created as common
# -Pxxx : defines the package
# -Zxxx : a prefix for variables within the classLib
# -Dxxx : defines passed to to CC for inline C-code
# -Ixxx : include path passed to CC for inline C-code
# +optspace : optimized for space
# +optspace2 : optimized more for space
# +optspace3 : optimized even more for space
# +optinline : generate inline code for some ST constructs
# +inlineNew : additionally inline new
# +inlineMath : additionally inline some floatPnt math stuff
#
# ********** OPTIONAL: MODIFY the next line(s) ***
# STCLOCALOPTIMIZATIONS=+optinline +inlineNew
# STCLOCALOPTIMIZATIONS=+optspace3
STCLOCALOPTIMIZATIONS=+optspace3
# Argument(s) to the stc compiler.
# -warn : no warnings
# -warnNonStandard : no warnings about ST/X extensions
# -warnEOLComments : no warnings about EOL comment extension
# -warnPrivacy : no warnings about privateClass extension
#
# ********** OPTIONAL: MODIFY the next line(s) ***
# STCWARNINGS=-warn
# STCWARNINGS=-warnNonStandard
# STCWARNINGS=-warnEOLComments
STCWARNINGS='.
(self propertyAt:#'make.stc.warnEOLComments') == false ifTrue:[
s nextPutAll:'-warnEOLComments '.
].
(self propertyAt:#'make.stc.warnNonStandard') == false ifTrue:[
s nextPutAll:'-warnNonStandard '.
].
s nextPutAll:((self propertyAt:#'make.stc.WARNINGOPTIONS') ? '') , '
# if your embedded C code requires any system includes,
# add the path(es) here:,
# ********** OPTIONAL: MODIFY the next lines ***
# LOCALINCLUDES=-Ifoo -Ibar
LOCALINCLUDES='.
s nextPutAll:((self propertyAt:#'make.stc.LOCALINCLUDES') ? '').
self prerequisitePackages do:[:aPackageId |
|prj|
s nextPutAll:'-I$(TOP)/../' , (aPackageId copyReplaceAll:$: with:$/) , ' '.
].
s nextPutAll:'
# if you need any additional defines for embedded C code,
# add them here:,
# ********** OPTIONAL: MODIFY the next lines ***
# LOCALDEFINES=-Dfoo -Dbar -DDEBUG
LOCALDEFINES=' , ((self propertyAt:#'make.stc.LOCALDEFINES') ? '') , '
STCLOCALOPT=-I. $(STCLOCALOPTIMIZATIONS) $(STCWARNINGS) $(LOCALINCLUDES) $(LOCALDEFINES) -H. ''-P$(PACKAGE)'' ''-Z$(LIBNAME)'' $(COMMONSYMFLAG) $(INITCODESEPFLAG)
# ********** OPTIONAL: MODIFY the next line ***
# additional C-libraries that should be pre-linked with the class-objects
LD_OBJ_LIBS=' , ((self propertyAt:#'make.LD_OBJ_LIBS') ? '') , '
# ********** OPTIONAL: MODIFY the next line ***
# additional C targets or libraries should be added below
LOCAL_EXTRA_TARGETS=' , ((self propertyAt:#'make.LOCAL_EXTRA_TARGETS') ? '') , '
'.
s nextPutAll:'
all:: preMake '.
notEmpty ifTrue:[
s nextPutAll:'classLibRule '
].
s nextPutAll:'postMake
'.
"/ type := #library.
"/ appName := 'app'.
"/ libName := 'lib'.
"/ startUpClass := 'Smalltalk'.
"/ startUpSelector := 'start'.
"/
"/ properties notNil ifTrue:[
"/ type := properties at:#projectType ifAbsent:type.
"/ appName := properties at:#applicationName ifAbsent:appName.
"/ startUpClass := properties at:#startupClass ifAbsent:startUpClass.
"/ startUpSelector := properties at:#startupSelector ifAbsent:startUpSelector.
"/ ].
"/
"/ s nextPutAll:'#
"/# define the name of the library to create
"/#
"/'.
"/ s nextPutAll:'LIBNAME=lib' , appName; cr; cr.
"/
"/ s nextPutAll:'#
"/# the target rule:
"/#
"/all:: abbrev.stc objs genClassList $(OBJTARGET)
"/
"/'.
"/
"/ type == #executable ifTrue:[
"/ s nextPutAll:'PROGS = ' , appName; cr.
"/ s nextPutAll:('STARTUP_CLASS=' , startUpClass); cr.
"/ s nextPutAll:'STARTUP_SELECTOR="' , startUpSelector; nextPutAll:'"'; cr.
"/ ].
"/
"/ s nextPutAll:'#
"/# define the object files that are to be created
"/#
"/'.
s nextPutAll:'OBJS='.
classes do:[:aClass |
|clsInfo cond include fileName|
clsInfo := self classInfoFor:aClass.
include := true.
clsInfo notNil ifTrue:[
cond := clsInfo conditionForInclusion.
(self conditionForInclusionIsTrue:cond) ifFalse:[
include := false.
] ifTrue:[
(self conditionForAutoloadIsTrue:cond) ifTrue:[
include := false
]
].
].
include ifTrue:[
s nextPutAll:' \'. s cr.
fileName := clsInfo classFileName.
fileName isNil ifTrue:[
fileName := Smalltalk fileNameForClass:aClass name.
].
fileName := fileName asFilename withoutSuffix name.
s nextPutAll:' '; nextPutAll:fileName; nextPutAll:'.$(O)'.
]
].
(methodsFile := self propertyAt:#methodsFile) size > 0 ifTrue:[
s nextPutAll:' \'. s cr.
s nextPutAll:' ';
nextPutAll:(methodsFile asFilename withoutSuffix baseName);
nextPutAll:'.$(O)'.
].
s cr.
self prerequisitePackages size > 0 ifTrue:[
s nextPutAll:'
# make required packages
prerequisites::
'.
self prerequisitePackages do:[:aPackageId |
|prj|
s tab; nextPutAll:'(cd $(TOP)/../' , (aPackageId copyReplaceAll:$: with:$/) , '; $(MAKE) ) '; cr.
].
s cr.
].
s nextPutAll:'
# add more install actions here
install::
# add more install actions for aux-files (resources) here
installAux::
# add more preMake actions here
preMake::
# add more postMake actions here
postMake:: cleanjunk
cleanjunk::
clean::
' , Character tab , '-rm -f *.o *.H
clobber::
' , Character tab , '-rm -f *.so *.dll
$(INSTALLBASE)::
' , Character tab , '@test -d $@ || mkdir -p $@
$(INSTALLBASE)/packages/$(MODULE)/$(MODULE_DIR):: $(INSTALLBASE)/packages/$(MODULE)
' , Character tab , '@test -d $@ || mkdir -p $@
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
'.
"/ classes notNil ifTrue:[
"/ classes do:[:aClass |
"/ |abbrev|
"/
"/ abbrev := Smalltalk fileNameForClass:aClass name.
"/ s nextPutAll:abbrev; nextPutAll:'.$(O): '.
"/ s nextPutAll:abbrev; nextPutAll:'.st '.
"/ aClass allSuperclassesDo:[:superClass|
"/ s nextPutAll:(Smalltalk fileNameForClass:superClass name) , '.$(H) '.
"/ ].
"/ s nextPutAll:'$(STCHDR)'; cr.
"/ ].
"/ ].
s nextPutAll:'# ENDMAKEDEPEND --- do not remove this line'.
s cr; cr.
type == #executable ifTrue:[
s nextPutAll:'all:: $(PROGS)'; cr.
s nextPutAll:appName.
s nextPutAll:':: main.o classList.o $(OBJS)'; cr.
s tab; nextPutAll:'$(LD) $(ST_LDFLAG) $(LDFLAGS) -o ';
nextPutAll:appName;
nextPutAll:' \'; cr.
s tab; tab; nextPutAll:'$(CRT0) main.$(O) classList.$(O) $(OBJS) $(EXTRA_OBJ) $(LIBOBJS) \'; cr.
s tab; tab; nextPutAll:'$(LIBRUNDIR)/hidata.o $(LIBRUN) \'; cr.
s tab; tab; nextPutAll:'$(MATHLIB) $(EXTRALIBS) -lXext $(SYSLIBS) $(OTHERLIBS) $(CRTN)'; cr.
].
s close
"Modified: / 23.3.1999 / 14:20:09 / cg"
!
createSourcefiles
"creates all Smalltalk-source files in the project directory"
|classes methods methodClasses dir stream|
dir := self directory asFilename.
Transcript current showCR:'creating sources in ' , dir pathName , ' ...'; endEntry.
classes := self classes.
classes size == 0 ifTrue:[
self warn:'no classes in current project'
] ifFalse:[
classes do:[:aClass |
aClass autoload.
].
"/ to not list private classes
classes := classes select:[:cls | cls owningClass isNil].
classes := classes topologicalSort:[:a :b | a isSubclassOf:b].
classes do:[:aClass |
Transcript current show:' ... '; showCR:aClass name, '.st'; endEntry.
aClass fileOutIn:dir
]
].
methods := self individualMethods.
methods size > 0 ifTrue:[
methods := methods asIdentitySet.
"
get classes ...
"
methodClasses := IdentitySet new.
methods do:[:m |
|mCls|
mCls := m containingClass.
mCls := mCls theNonMetaclass.
methodClasses add:mCls].
"
fileOut by class
"
methodClasses do:[:cls |
stream := (self directory asFilename construct:(cls name , '.chg')) writeStream.
Transcript current show:' ... '; showCR:cls name, '.chg'; endEntry.
methods do:[:m |
|mCls|
mCls := m containingClass.
(mCls == cls or:[mCls == cls class]) ifTrue:[
mCls fileOutMethod:m on:stream.
].
stream cr.
].
stream close.
].
].
"Modified: / 18.9.1997 / 18:50:34 / stefan"
"Modified: / 5.11.2001 / 16:46:17 / cg"
!
createVMSMakefile
"creates an vms.mak makefile"
Transcript current showCR:'VMS support not yet implemented - no vms.mak created'.
!
findTopFrom:directoryName
"returns the relative path from directoryName to the TOP
directory."
|topName relParent foundTop|
"/ find TOP
relParent := '..'.
foundTop := false.
[foundTop] whileFalse:[
topName := directoryName asFilename construct:relParent.
((topName construct:'stx') construct:'configurations') exists ifTrue:[
((topName construct:'stx') construct:'include') exists ifTrue:[
^ relParent asFilename constructString:'stx'.
]
].
(topName construct:'configurations') exists ifTrue:[
(topName construct:'include') exists ifTrue:[
^ relParent asFilename name
]
].
relParent := relParent asFilename constructString:'..'.
topName isRootDirectory ifTrue:[
self warn:'could not find TOP; assume absolute path to TOP'.
^ nil.
"/ topName := '/usr/local/lib/smalltalk'.
"/ foundTop := true.
]
].
^ topName pathName
"Modified: / 26.9.1999 / 16:15:14 / cg"
! !
!Project methodsFor:'printing & storing'!
displayString
^ super displayString , '(''' , (name ? '<unnamed>') , ''')'
! !
!Project methodsFor:'properties'!
addClass:classOrClassName
"add a class to the project"
|fn|
(classOrClassName isBehavior and:[classOrClassName isLoaded]) ifTrue:[
fn := classOrClassName classFilename.
].
fn isNil ifTrue:[
fn := (Smalltalk fileNameForClass:classOrClassName) , '.st'
].
self addClass:classOrClassName classFileName:fn
!
addClass:classOrClassName classFileName:fileName
"add a class to the project"
self
addClass:classOrClassName
conditionForInclusion:#always
classFileName:fileName
!
addClass:classOrClassName conditionForInclusion:conditionBlock classFileName:fileName
"add a class to the project"
|i clsName|
(clsName := classOrClassName) isBehavior ifTrue:[
clsName := classOrClassName name
].
(clsName startsWith:'Smalltalk::') ifTrue:[
clsName := clsName copyFrom:'Smalltalk::' size + 1.
].
i := ClassInfo new.
i className:clsName.
i classFileName:fileName.
i conditionForInclusion:conditionBlock.
self addClassInfo:i
!
addClassInfo:newInfo
"add a class info to the project"
|infoCollection index nm prefix|
(infoCollection := self classInfo) isNil ifTrue:[
self classInfo:(infoCollection := OrderedCollection new).
].
index := infoCollection findFirst:[:i | |nm1 nm2|
nm1 := i className.
nm2 := newInfo className.
nm1 = nm2
].
index ~~ 0 ifTrue:[
infoCollection at:index put:newInfo
] ifFalse:[
infoCollection add:newInfo
]
!
addMethod:methodName inClass:classOrClassName conditionForInclusion:condition fileName:optionalFileName
"add a method to the project"
|i|
i := MethodInfo new.
i className:classOrClassName.
i methodName:methodName.
i fileName:optionalFileName.
i conditionForInclusion:condition.
self addMethodInfo:i
!
addMethod:methodOrSelector inClass:aClassOrClassName fileName:fileName
"add an individual method to the project"
|i|
i := MethodInfo new.
i methodName:methodOrSelector.
i className:aClassOrClassName.
i fileName:fileName.
self addMethodInfo:i
!
addMethodInfo:newInfo
"add a method info to the project"
|infoCollection index nm prefix|
prefix := self defaultNameSpace name , '::'.
infoCollection := self methodInfo.
index := infoCollection findFirst:[:i | |cnm1 cnm2|
cnm1 := i className.
cnm2 := newInfo className.
(cnm1 includes:$:) ifFalse:[
cnm1 := prefix , cnm1
].
(cnm2 includes:$:) ifFalse:[
cnm2 := prefix , cnm2
].
cnm1 = cnm2 and:[i methodName = newInfo methodName]
].
"/ strip off nameSpace prefix, if its the same as
"/ the default ...
nm := newInfo className.
(nm startsWith:prefix) ifTrue:[
nm := nm copyFrom:(prefix size + 1).
newInfo className:nm asSymbol.
].
index ~~ 0 ifTrue:[
infoCollection at:index put:newInfo
] ifFalse:[
infoCollection add:newInfo
]
!
classInfo:aClassInfoCollection
"set the class info of the project"
self propertyAt:#classInfo put:aClassInfoCollection
!
comment
"return the comment of the project"
properties isNil ifTrue:[^ ''].
^ properties at:#comment ifAbsent:''
!
comment:aString
"set the projects comment"
self propertyAt:#comment put:aString
!
documentationURL
"return the documentation-URL of the project"
properties isNil ifTrue:[^ nil].
^ properties at:#documentationURL ifAbsent:nil
!
documentationURL:anURLString
"set the projects documentation-URL"
self propertyAt:#documentationURL put:anURLString
!
methodInfo:aMethodInfoCollection
"set the method info of the project"
self propertyAt:#methodInfo put:aMethodInfoCollection
!
properties
"return the property dictionary"
^ properties
!
properties:p
"set the property dictionary"
properties := p
!
propertyAt:aKey
"return a property; the key is a symbol"
properties isNil ifTrue:[^ nil].
^ properties at:aKey ifAbsent:nil.
!
propertyAt:aKey put:aValue
"set a property; the key is a symbol"
|oldValue|
oldValue := self propertyAt:aKey.
properties isNil ifTrue:[
properties := IdentityDictionary new
].
properties at:aKey put:aValue.
oldValue ~~ aValue ifTrue:[
self changed:aKey.
].
"Created: / 23.3.1999 / 14:21:11 / cg"
!
removeClass:classOrClassName
"remove a class from the project"
|infoCollection index className|
(infoCollection := self classInfo) isNil ifTrue:[^ self].
(className := classOrClassName) isBehavior ifTrue:[
className := classOrClassName name
].
index := infoCollection findFirst:[:i | i className = className.].
index ~~ 0 ifTrue:[
infoCollection removeIndex:index
]
!
removeMethod:method
"remove a method from the project"
|infoCollection index className selector|
(infoCollection := self methodInfo) size == 0 ifTrue:[^ self].
className := method who methodClass name.
selector := method who methodSelector.
index := infoCollection findFirst:[:i | i className = className.].
index ~~ 0 ifTrue:[
infoCollection removeIndex:index
]
!
type
"return the type of project (one of #application, #library, #smalltalk)"
properties isNil ifTrue:[^ #application].
^ properties at:#type ifAbsent:#application
!
type:aSymbol
"set the projects type (one of #application, #library, #smalltalk)"
|sym|
(sym := aSymbol) == #classLibrary ifTrue:[
sym := #library
].
(#(application library extension smalltalk) includes:sym) ifFalse:[
self warn:'invalid project type'.
^ self
].
self propertyAt:#type put:sym
!
wasLoadedFromFile
"return true, if the project was loaded from a file"
properties isNil ifTrue:[^ nil].
^ properties at:#wasLoadedFromFile ifAbsent:false
"Modified: / 23.3.1999 / 13:59:32 / cg"
"Created: / 23.3.1999 / 14:21:06 / cg"
!
wasLoadedFromFile:aBoolean
"set/clear the flag stating that the project was loaded from a file"
self propertyAt:#wasLoadedFromFile put:aBoolean
! !
!Project methodsFor:'queries'!
areAllClassesLoaded
"return true, if all classes of the package are loaded
(i.e. there are no autoloaded stubs present)"
|classes|
classes := self classes.
classes size == 0 ifTrue:[^ isLoaded ? false].
classes do:[:aClass |
aClass isBehavior ifFalse:[^ false].
aClass isLoaded ifFalse:[^ false].
].
^ true
!
classInfo
"return a classInfo collection of classes belonging to that project"
|classInfo classes|
properties notNil ifTrue:[
classInfo := properties at:#classInfo ifAbsent:nil.
classInfo notNil ifTrue:[^ classInfo].
].
classes := self classes.
classes size == 0 ifTrue:[
classInfo := OrderedCollection new
] ifFalse:[
classInfo := classes asOrderedCollection
collect:[:class |
|i fn|
i := ClassInfo new.
i conditionForInclusion:#always.
i className:class name.
fn := class classFilename ? ((Smalltalk fileNameForClass:class) , '.st').
i classFileName:fn.
i
]
].
self propertyAt:#classInfo put:classInfo.
^ classInfo
"Modified: 4.1.1997 / 16:51:18 / cg"
!
classInfoFor:aClassOrClassName
"return a classInfo for a particular class"
|classInfo clsName index|
(classInfo := self classInfo) isNil ifTrue:[^ nil].
(clsName := aClassOrClassName) isBehavior ifTrue:[
clsName := aClassOrClassName name
].
^ classInfo detect:[:i | i className = clsName] ifNone:nil.
"Modified: 4.1.1997 / 16:51:18 / cg"
!
classes
"return a collection of classes belonging to that project.
This excludes any private classes."
|classes classInfo|
properties notNil ifTrue:[
classInfo := properties at:#classInfo ifAbsent:nil.
classInfo notNil ifTrue:[
classes := classInfo collect:[:i | i className]
] ifFalse:[
classes := properties at:#classes ifAbsent:nil
]
].
(properties isNil
or:[properties at:#autoIncludeImageClasses ifAbsent:true])
ifTrue:[
classes isNil ifTrue:[
classes := OrderedCollection new.
Smalltalk
allClassesDo:[:aClass |
(true "aClass owningClass isNil"
and:[aClass isMeta not
and:[aClass package = packageName
and:[aClass isNameSpace not or:[aClass == Smalltalk]]]]) ifTrue:[
classes add:aClass
]
].
].
].
^ classes ? #()
"Modified: 4.1.1997 / 16:51:18 / cg"
!
includesClass:aClassOrClassName
"return true, if a class is contained in the project"
|infoCollection index className|
(infoCollection := self classInfo) isNil ifTrue:[^ false].
aClassOrClassName isBehavior ifTrue:[
className := aClassOrClassName name
] ifFalse:[
className := aClassOrClassName
].
index := infoCollection findFirst:[:i | |nm1 nm2|
i className = className
].
^ index ~~ 0
!
includesMethod:aMethod
"return true, if the given method is contained in the project
(either as patch/extension or as class"
|who methodClass|
who := aMethod who.
who isNil ifTrue:[^ false].
methodClass := who methodClass.
(self includesClass:methodClass) ifTrue:[^ true].
^ self includesMethodPatch:aMethod
!
includesMethodPatch:aMethod
"return true, if the given method is contained in the project
as patch/extension"
|who methodClass methodClassName methodSelector infoCollection index className selector|
who := aMethod who.
who isNil ifTrue:[^ false].
methodClass := who methodClass.
methodClassName := methodClass name.
methodSelector := who methodSelector.
infoCollection := self methodInfo.
index := infoCollection findFirst:[:i |
(i className = methodClassName
and:[i methodName = methodSelector])
].
^ index ~~ 0
!
individualMethods
"return a collection of individual methods belonging to that project,
only methods are returned which are not contained in the
projects class set."
"/
"/ obsoleted by #methods ...
"/
|classes methods|
classes := self classes.
classes size > 0 ifTrue:[
classes := classes asIdentitySet.
].
methods := IdentitySet new.
Smalltalk allClassesDo:[:cls |
|classToCheck|
classToCheck := cls.
"/ cls isPrivate ifTrue:[
"/ classToCheck := cls topOwningClass
"/ ].
((classes includes:classToCheck)
or:[classes includes:classToCheck name]) not
ifTrue:[
cls instAndClassSelectorsAndMethodsDo:[:sel :m |
m package = packageName ifTrue:[
methods add:m
]
].
]
].
^ methods asArray
"
Project current classes
Project current individualMethods
"
"Modified: 7.6.1996 / 09:16:25 / stefan"
!
isDefaultProject
^ self == Project defaultProject
!
isLoaded
"return true, if all of this project-package has been loaded
into the system"
|binaryModule cls|
isLoaded == true ifTrue:[^ isLoaded].
"/ check for loaded class-library - assume loaded if present.
binaryModule := ObjectMemory binaryModuleInfo detect:[:i | i package = self package] ifNone:nil.
binaryModule notNil ifTrue:[
isLoaded := true.
^ true
].
"/ check for all classes ...
self classes do:[:aClassOrClassName |
aClassOrClassName isBehavior ifFalse:[
aClassOrClassName isString ifTrue:[
(cls := Smalltalk at:aClassOrClassName asSymbol) isNil ifTrue:[
^ false
].
cls isBehavior ifFalse:[^ false].
cls isLoaded ifFalse:[^ false].
] ifFalse:[
self halt.
^ false
]
]
].
"/ check for all patches & extensions ...
self methods do:[:aMethodInfo |
aMethodInfo theMethod isNil ifTrue:[
^ false
].
].
isLoaded := true.
^ true
"
(Project projectWithId:#'stx:libbasic') isLoaded
(Project projectWithId:#'stx:goodies/persistency') isLoaded
"
"Modified: / 26.9.1999 / 13:39:55 / cg"
!
methodInfo
"return a methodInfo collection of methods belonging to that project"
|methodInfo methods|
properties notNil ifTrue:[
methodInfo := properties at:#methodInfo ifAbsent:nil.
methodInfo notNil ifTrue:[^ methodInfo].
].
methods := self methods.
methods size == 0 ifTrue:[
methodInfo := OrderedCollection new
] ifFalse:[
methodInfo := methods asOrderedCollection
collect:[:mthd |
|i fn who className selector|
mthd isMethod ifTrue:[
who := mthd who.
className := who methodClass name.
selector := who methodSelector.
i := MethodInfo new.
i conditionForInclusion:#always.
i className:className.
i methodName:className.
fn := mthd sourceFilename.
i fileName:fn.
i
] ifFalse:[
mthd "/ already a methodInfo
]
]
].
self propertyAt:#methodInfo put:methodInfo.
^ methodInfo
"Modified: 4.1.1997 / 16:51:18 / cg"
!
methods
"return a collection of methods belonging to that project.
This excludes any methods which are already in my class-set."
|methods methodsInfo|
properties notNil ifTrue:[
methodsInfo := properties at:#methodsInfo ifAbsent:nil.
methodsInfo notNil ifTrue:[
methods := methodsInfo collect:[:i | i className]
] ifFalse:[
methods := properties at:#methods ifAbsent:nil
]
].
methods isNil ifTrue:[
methods := OrderedCollection new.
Smalltalk allClassesDo:[:aClass |
(true "aClass owningClass isNil"
and:[aClass isMeta not
and:[aClass package ~= packageName
and:[aClass isNameSpace not or:[aClass == Smalltalk]]]]) ifTrue:[
aClass methodDictionary keysAndValuesDo:[:sel :mthd |
mthd package = packageName ifTrue:[
methods add:(MethodInfo new
className:aClass name;
methodName:sel;
yourself)
].
].
aClass class methodDictionary keysAndValuesDo:[:sel :mthd |
mthd package = packageName ifTrue:[
methods add:(MethodInfo new
className:(aClass name , ' class');
methodName:sel;
yourself)
].
]
]
].
methods isEmpty ifTrue:[^ #()].
].
^ methods
"Modified: 4.1.1997 / 16:51:18 / cg"
! !
!Project methodsFor:'specifications'!
readSpec
|s chunk fileName|
fileName := (properties at:#directoryName) asFilename construct:'.project'.
s := fileName readStreamOrNil.
s isNil ifTrue:[^ self].
[s atEnd] whileFalse:[
chunk := s nextChunk.
Compiler evaluate:chunk receiver:properties notifying:nil
].
s close.
"(Project new directory:'../projects/Clock') readSpec"
!
saveSpec
|f d s|
d := (properties at:#directoryName) asFilename.
d exists ifFalse:[
self error:'directory does not exist' mayProceed:true.
^ self
].
f := d construct:'.project'.
s := f writeStream.
s checkNilFileStream.
properties associationsDo:[:aProp |
(aProp == #directoryName) ifFalse:[
s nextChunkPut:('self at:' , aProp key storeString,
' put:' , aProp value storeString).
s cr
]
].
s close
"((Project new directory:'../projects/Clock') readSpec
directory:'../projects/xxx') saveSpec"
! !
!Project methodsFor:'views'!
addView:aView
"add a view to this projects set of views"
views notNil ifTrue:[views add:aView]
"Modified: 14.2.1997 / 15:36:51 / cg"
!
destroyViews
"destroy all views of this project"
views notNil ifTrue:[
views do:[:aView |
aView notNil ifTrue:[aView destroy]
]
].
!
hideViews
"hide all views of this project"
views notNil ifTrue:[
views do:[:aView |
aView notNil ifTrue:[aView unmap]
]
].
"Modified: 3.5.1996 / 23:48:51 / stefan"
!
removeView:aView
"remove a view from this projects set of views"
views notNil ifTrue:[
views remove:aView ifAbsent:nil
]
"Modified: 14.2.1997 / 15:37:20 / cg"
!
showViews
"show all views of this project"
views notNil ifTrue:[
views do:[:aView |
aView notNil ifTrue:[aView remap]
]
].
"Modified: 3.5.1996 / 23:59:10 / stefan"
"Modified: 14.2.1997 / 15:38:47 / cg"
! !
!Project::ClassInfo methodsFor:'accessing'!
classFileName
"return the value of the instance variable 'classFileName' (automatically generated)"
^ classFileName
!
classFileName:something
"set the value of the instance variable 'classFileName' (automatically generated)"
classFileName := something.
!
className
"return the value of the instance variable 'className' (automatically generated)"
^ className
!
className:something
"set the value of the instance variable 'className' (automatically generated)"
className := something.
!
conditionForInclusion
"return the value of the instance variable 'conditionForInclusion' (automatically generated)"
^ conditionForInclusion
!
conditionForInclusion:something
"set the value of the instance variable 'conditionForInclusion' (automatically generated)"
conditionForInclusion := something.
! !
!Project::ClassInfo methodsFor:'printing & storing'!
displayString
^ 'ClassInfo: ' , className
! !
!Project::ClassInfo methodsFor:'queries'!
theClass
|cls|
cls := Smalltalk classNamed:className.
cls isNil ifTrue:[ ^ nil].
^ cls
"Created: / 26.9.1999 / 13:39:00 / cg"
! !
!Project::MethodInfo methodsFor:'accessing'!
className
"return the value of the instance variable 'className' (automatically generated)"
^ className
!
className:something
"set the value of the instance variable 'className' (automatically generated)"
className := something.
!
conditionForInclusion
"return the value of the instance variable 'conditionForInclusion' (automatically generated)"
^ conditionForInclusion
!
conditionForInclusion:something
"set the value of the instance variable 'conditionForInclusion' (automatically generated)"
conditionForInclusion := something.
!
fileName
"return the value of the instance variable 'fileName' (automatically generated)"
^ fileName
!
fileName:something
"set the value of the instance variable 'fileName' (automatically generated)"
fileName := something.
!
methodName
"return the value of the instance variable 'methodName' (automatically generated)"
^ methodName
!
methodName:something
"set the value of the instance variable 'methodName' (automatically generated)"
methodName := something.
! !
!Project::MethodInfo methodsFor:'printing & storing'!
displayString
^ 'MethodInfo: ' , className , ' ' , methodName
! !
!Project::MethodInfo methodsFor:'queries'!
method
self obsoleteMethodWarning.
^ self theMethod.
"Modified: / 26.9.1999 / 13:40:16 / cg"
!
theMethod
|cls|
cls := Smalltalk classNamed:className.
cls isNil ifTrue:[ ^ nil].
^ cls compiledMethodAt:methodName asSymbol.
"Created: / 26.9.1999 / 13:39:07 / cg"
! !
!Project class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Project.st,v 1.186 2003-04-23 17:23:37 cg Exp $'
! !
Project initialize!