"

 COPYRIGHT (c) 1989 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' }"

ClassDescription subclass:#Class

	instanceVariableNames:'name category classvars comment subclasses classFilename package

		revision primitiveSpec environment signature hook'

	classVariableNames:'DefaultCategoryForSTV DefaultCategoryForVAGE'

	poolDictionaries:''

	category:'Kernel-Classes'

!

!Class class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1989 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

"

    Class adds more functionality to classes; minimum stuff has already

    been defined in Behavior and ClassDescription; this adds naming, categories etc.

    [Instance variables:]

        name            <Symbol>        the classes name

        category        <Symbol>        the classes category

        classvars       <String>        the names of the class variables

        comment         <String>        the classes comment; either a string,

                                        a number specifying the offset in classFilename, or nil

        subclasses      <Collection>    cached collection of subclasses

                                        (currently unused - but will be soon)

        classFilename   <String>        the file (or nil) where the classes

                                        sources are found 

        package         <Symbol>        the package, in which the class was defined

                                        (inserted by compilers)

        revision        <String>        revision string - inserted by stc

        primitiveSpec   <Array | nil>   describes primitiveIncludes, primitiveFunctions etc.

        environment     <Symbol | nil>  cached environment (i.e. Smalltalk or a namespace)

                                        of class

        signature       <SmallInteger>  the classes signature (used to detect obsolete

                                        or changed classes with binaryStorage)

                                        This is filled in lazy - i.e. upon the first signature query.

        hook            <any>           reserved: a place to add additional attributes,

                                        without a need to recompile all classes.

                                        Currently unused.

    WARNING: layout known by compiler and runtime system

    [author:]

        Claus Gittinger

    [see also:]

        Behavior ClassDescription Metaclass

"

! !

!Class class methodsFor:'accessing-flags'!

tryLocalSourceFirst

    ^ TryLocalSourceFirst

    "Created: 24.1.1996 / 19:55:35 / cg"

!

tryLocalSourceFirst:aBoolean

    TryLocalSourceFirst := aBoolean

    "Created: 24.1.1996 / 19:55:35 / cg"

!

updateChanges:aBoolean

    "turn on/off changes management. Return the prior value of the flag.

     This value is used as a default fallback - a querySignal handler may still 

     decide to return something else."

    |prev|

    prev := UpdatingChanges.

    UpdatingChanges := aBoolean.

    ^ prev

!

updatingChanges

    "return true if changes are recorded.

     The value returned here is the default fallback - a querySignal handler may still

     decide to return something else."

    ^ UpdatingChanges

! !

!Class class methodsFor:'helpers'!

revisionInfoFromString:aString

    "{ Pragma: +optSpace }"

    "return a dictionary filled with revision info.

     This extracts the relevant info from aString, asking

     the sourceCode manager (if there is one)"

    "

     For now, this is a bad design - since the sourceCodeManager

     is not always delivered, here, a fallBack is provided.

     (should probably deliver some RCS-header extractor in any case,

      even if no AbstractSourceCodeManager is present)

     (knowing about the details of RCS headers here is a bad design ...)

    "

    |words info nm mgr|

    "/

    "/ mhmh - ask the default manager

    "/

    (mgr := Smalltalk at:#SourceCodeManager) notNil ifTrue:[

        info := mgr revisionInfoFromString:aString.

        info notNil ifTrue:[

            ^ info

        ]

    ].

    "/

    "/ fallBack - handles some RCS headers only

    "/ is this really needed ?

    "/

    info := IdentityDictionary new.

    words := aString asCollectionOfWords.

    words notEmpty ifTrue:[

        "/

        "/ supported formats:

        "/

        "/ $-Header: pathName rev date time user state $

        "/ $-Revision: rev $

        "/ $-Id: fileName rev date time user state $

        "/

        ((words at:1) = '$Header:') ifTrue:[

            nm := words at:2.

            info at:#repositoryPathName put:nm.

            (nm endsWith:',v') ifTrue:[

                nm := nm copyWithoutLast:2

            ].

            info at:#fileName put:nm asFilename baseName.

            words size > 2 ifTrue:[

                (words at:3) = '$' ifFalse:[

                    info at:#revision put:(words at:3).

                    (words at:4) = '$' ifFalse:[

                        info at:#date put:(words at:4).

                        info at:#time put:(words at:5).

                        info at:#user put:(words at:6).

                        info at:#state put:(words at:7).

                    ]

                ].

            ].

            ^ info

        ].

        ((words at:1) = '$Revision:') ifTrue:[

            info at:#revision put:(words at:2).

            ^ info

        ].

        ((words at:1) = '$Id:') ifTrue:[

            info at:#fileName put:(words at:2).

            info at:#revision put:(words at:3).

            info at:#date put:(words at:4).

            info at:#time put:(words at:5).

            info at:#user put:(words at:6).

            info at:#state put:(words at:7).

            ^ info

        ].

    ].

    ^ nil

    "Created: 15.11.1995 / 14:58:35 / cg"

    "Modified: 29.1.1997 / 19:36:31 / cg"

!

revisionStringFromSource:aMethodSourceString

    "{ Pragma: +optSpace }"

    "extract a revision string from a methods source string"

    |lines line|

    lines := aMethodSourceString asCollectionOfLines.

    lines do:[:l |

        |i|

        i := l indexOfSubCollection:'$Header: '.

        i ~~ 0 ifTrue:[

            line := l copyFrom:i.

            i := line lastIndexOf:$$.

            i > 1 ifTrue:[

                line := line copyTo:i.

            ].

            ^ line

        ]

    ].

    ^ nil

    "Created: 15.10.1996 / 18:57:57 / cg"

    "Modified: 16.10.1996 / 16:54:40 / cg"

! !

!Class class methodsFor:'misc'!

template:aCategoryString

    "return a class-definition template"

    ^ 'NameOfSuperclass subclass:#NameOfClass

    instanceVariableNames:''instVarName1 instVarName2''

    classVariableNames:''classVarName1 classVarName2''

    poolDictionaries:''''

    category:''' , aCategoryString , ''''

    "Created: / 19.6.1998 / 02:09:06 / cg"

! !

!Class class methodsFor:'queries'!

isBuiltInClass

    "return true if this class is known by the run-time-system.

     Here, true is returned for myself, false for subclasses."

    ^ self == Class class or:[self == Class]

    "Created: 15.4.1996 / 17:17:13 / cg"

    "Modified: 23.4.1996 / 15:56:58 / cg"

! !

!Class methodsFor:'Compatibility - ST/V and V''Age'!

defaultCategoryForSTVorVAGEClasses

    |cat app|

    DefaultApplicationQuerySignal isHandled ifTrue:[

        app := DefaultApplicationQuerySignal query.

        app notNil ifTrue:[

            cat := 'Applications-' , app name.

        ] ifFalse:[

            cat := DefaultCategoryForVAGE ? 'V''Age classes'.

        ].

    ] ifFalse:[

        cat := DefaultCategoryForSTV ? 'ST/V classes'.

    ].

    ^ cat

!

subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age classes 

     (which seem to have no category)"

    ^ self subclass:t 

           instanceVariableNames:f

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

    "Modified: / 15.6.1998 / 21:31:34 / cg"

    "Modified: / 18.3.1999 / 18:16:11 / stefan"

!

variableByteSubclass:t classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable byte classes 

     (which seem to have no category and no instvars)"

    ^ self variableByteSubclass:t 

           instanceVariableNames:''

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

    "Modified: / 15.6.1998 / 21:31:38 / cg"

    "Modified: / 18.3.1999 / 18:16:21 / stefan"

!

variableLongSubclass:t classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable long (32bit integers) classes 

     (which seem to have no category and no instvars)"

    ^ self variableLongSubclass:t 

           instanceVariableNames:''

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

!

variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable pointer classes 

     (which seem to have no category)"

    ^ self variableSubclass:t 

           instanceVariableNames:f

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

    "Modified: / 15.6.1998 / 21:31:41 / cg"

    "Modified: / 18.3.1999 / 18:16:33 / stefan"

!

variableWordSubclass:t classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable word (16bit integers) classes 

     (which seem to have no category and no instvars)"

    ^ self variableWordSubclass:t 

           instanceVariableNames:''

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

! !

!Class methodsFor:'Compatibility - ST80'!

fileOutSourceOn:aStream

    self fileOutOn:aStream withTimeStamp:false

    "Created: 20.6.1997 / 17:18:14 / cg"

    "Modified: 20.6.1997 / 17:18:26 / cg"

!

isStartableWithMain

    "return true, if this is an application class,

     which can be started via #main"

    ^ self theMetaclass includesSelector:#main

    "Created: / 2.11.2001 / 09:37:01 / cg"

    "Modified: / 2.11.2001 / 09:48:05 / cg"

!

isVisualStartable

    "return true, if this is an application class,

     which can be started via #open"

    ^ false

    "Created: / 27.10.1997 / 16:42:05 / cg"

!

rename:newName

    "same as renameTo: - for ST80 compatibility"

    ^ Smalltalk renameClass:self to:newName.

"/    ^ self renameTo:newName

    "Created: / 18.6.1998 / 22:08:45 / cg"

! !

!Class methodsFor:'accessing'!

addClassVarName:aString

    "add a class variable if not already there and initialize it with nil.

     Also writes a change record and notifies dependents."

    |namespace|

    (self classVarNames includes:aString) ifFalse:[

        self classVariableString:(self classVariableString , ' ' , aString).

        Class withoutUpdatingChangesDo:[

            self withAllSubclasses do:[:cls|

                cls recompileMethodsAccessingAnyClassvarOrGlobal:

                                        (Array with:aString asSymbol)

            ].

        ].

        self addChangeRecordForClass:self.

        self changed:#definition.

        (namespace := self nameSpace) changed:#classDefinition with:self.

        namespace ~~ Smalltalk ifTrue:[

            Smalltalk changed:#classDefinition with:self.

        ].

        (namespace := self nameSpace) changed:#classVariables with:self.

        namespace ~~ Smalltalk ifTrue:[

            Smalltalk changed:#classVariables with:self.

        ].

    ]

    "Created: / 29.10.1995 / 19:40:51 / cg"

    "Modified: / 23.1.1998 / 15:46:23 / stefan"

!

allPrivateClasses

    "{ Pragma: +optSpace }"

    "return a collection of all private classes and private-private classes.

     The classes are in any order."

    ^ self privateClassesOrAll:true

!

category

    "return the category of the class. 

     The returned value may be a string or symbol."

    |owner|

    (owner := self owningClass) notNil ifTrue:[^ owner category].

    ^ category

    "

     Point category                

     Dictionary category           

    "

    "Modified: 15.10.1996 / 21:20:01 / cg"

    "Created: 1.4.1997 / 15:23:47 / stefan"

!

category:aStringOrSymbol

    "set the category of the class to be the argument, aStringOrSymbol"

    self setCategory:aStringOrSymbol.

!

classFilename

    "return the name of the file from which the class was compiled."

    |owner|

    (owner := self owningClass) notNil ifTrue:[^ owner classFilename].

    ^ classFilename

    "Modified: 15.10.1996 / 18:53:21 / cg"

!

classVarAt:aSymbol

    "return the value of a class variable.

     Currently, this returns nil if there is no such classvar -

     this may change."

    "

     this hides the (current) implementation of classVariables

     from the outside world. Currently, classvars are stored in

     the Smalltalk dictionary with a funny name, since there are

     no classPools yet.

    "

    ^ Smalltalk at:(self name , ':' , aSymbol) asSymbol

!

classVarAt:aSymbol ifAbsent:exceptionBlock

    "return the value of a class variable.

     Currently, this returns nil if there is no such classvar -

     this may change."

    "