"{ Package: 'stx:goodies/ring/tests' }"

"{ NameSpace: Smalltalk }"

TestCase subclass:#RGClassDefinitionTest

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'Ring-Core-Kernel-Tests'

!

RGClassDefinitionTest comment:'SUnit tests for class definitions'

!

!RGClassDefinitionTest methodsFor:'testing'!

testAddingMethods

    | newMethod newClass |

    newClass:= RGClassDefinition named:  #OrderedCollection.

    newMethod:= (RGMethodDefinition named: #add:)

                     parent: newClass;

                    protocol: 'adding';

                    sourceCode: 'add: newObject

                                    ^self addLast: newObject'.

    self assert: (newMethod isMetaSide not).

    self assert: (newClass hasMethods not).

    newClass addMethod: newMethod.

    newClass addSelector: #size 

               classified: 'accessing' 

               sourced: 'fakeMethod

                            ^lastIndex - firstIndex + 1'.

    self assert: (newClass hasMethods).

    self assert: (newClass selectors size == 2).

    self assert: (newClass selectors includesAll: #(add: size)).

    self assert: (newClass includesSelector: #add:).

    self assert: ((newClass methodNamed: #add:) = newMethod).

    self assert: (newClass methods size = 2).

    self assert: (newClass selectors size = 2).

    self assert: (newClass allSelectors size = 2).  "no hierarchy"

    newMethod:= newClass methodNamed: #size.

    self assert: (newMethod parent = newClass).

    self assert: ((newClass compiledMethodNamed: #size) notNil).

    self assert: ((newClass compiledMethodNamed: #fakeMethod) isNil)

    "Modified: / 29-08-2015 / 08:04:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testAsClassDefinition

    | newClass |

    newClass:= OrderedCollection asRingDefinition.

    self assert: (newClass isRingObject).

    self assert: (newClass isClass).  

    self assert: (newClass name == #OrderedCollection).  

    self assert: (newClass category notNil).

    self assert: (newClass superclassName notNil).

    self assert: (newClass theMetaClass isRingObject).

    self assert: (newClass theMetaClass isClass).

!

testAsClassDefinition2

    | newClass |

    newClass:= Class asRingDefinition.

    self assert: (newClass isRingObject).

    self assert: (newClass isClass).  

    self assert: (newClass name == #Class).  

    self assert: (newClass category notNil).

    self assert: (newClass superclassName notNil).

"/    self assert: (newClass  traitCompositionSource = 'TClass').

    self assert: (newClass theMetaClass isRingObject).

    self assert: (newClass theMetaClass isClass).

"/    self assert: (newClass theMetaClass traitCompositionSource = 'TClass classTrait').

    "Modified: / 29-08-2015 / 08:05:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testAsClassDefinitionSourceDefinition

    | newClass |

    newClass:= Class asRingDefinition.

    self assert: (newClass definitionSource = '"{ Package: ''stx:libbasic'' }"

"{ NameSpace: Smalltalk }"

ClassDescription subclass:#Class

        instanceVariableNames:''name category classvars comment subclasses classFilename package

                revision environment signature attributes''

        classVariableNames:''DefaultCategoryForSTV DefaultCategoryForVAGE

                DefaultCategoryForDolphin ValidateSourceOnlyOnce ValidatedClasses

                SubclassCacheSequenceNumber

                DefaultCategoryForUncategorizedClasses

                DefaultCategoryForUndeclaredClasses''

        poolDictionaries:''''

        category:''Kernel-Classes''

').

    self assert: (newClass theMetaClass definitionSource= 'Class class instanceVariableNames:''''

"

 No other class instance variables are inherited by this class.

"

').

    "Modified (format): / 29-08-2015 / 08:07:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testAsRingDefinition

    self assert: OrderedCollection asRingDefinition asRingDefinition isRingObject

!

testClassEquality

    | newClass |

    self assert: OrderedCollection asRingDefinition = OrderedCollection asRingDefinition.

    newClass := (OrderedCollection asRingDefinition)

        category: #Kernel.

    self assert: (OrderedCollection asRingDefinition = newClass) 

!

testExistingClass

    | newClass metaClass |

    newClass:= RGClassDefinition named:  #OrderedCollection.

    self assert: (newClass isClass).

    self assert: (newClass isDefined).

    self assert: (newClass realClass = OrderedCollection).

    self assert: (newClass isMeta not).

    newClass withMetaclass.

    self assert: (newClass hasMetaclass).

    metaClass:= newClass theMetaClass.

    self assert: (metaClass isMeta).

    self assert: (metaClass name = 'OrderedCollection class').

    self assert: (metaClass theNonMetaClass = newClass).

    self assert: (metaClass realClass = OrderedCollection class).

!

testNonExistingClass

    | newClass |

    newClass:= RGClassDefinition named:  #Connection.

    self assert: (newClass isClass).

    self assert: (newClass instanceVariables isEmpty).

    self assert: (newClass classVariables isEmpty).

    self assert: (newClass sharedPools isEmpty).

    self assert: (newClass hasMetaclass not).

    self assert: (newClass hasComment not).

    self assert: (newClass hasStamp not).

    self assert: (newClass parent = Smalltalk globals).

    self assert: (newClass package isNil).

    self assert: (newClass category isNil).

    self assert: (newClass hasMethods not).

    self assert: (newClass hasSuperclass not).

    self assert: (newClass hasTraitComposition not).

    self assert: (newClass isDefined not).

    self assert: (newClass hasProtocols not).

!

testReadFrom

    "self debug: #testReadFrom"

    | st rg |

    rg := Point asRingDefinition.

    st := String streamContents: [:s |

        rg storeOn: s.

        s contents].

    self assert: (Object readFrom: st) = rg. 

    rg := Point class asRingDefinition.

    st := String streamContents: [:s |

        rg storeOn: s.

        s contents].

    self assert: (Object readFrom: st) = rg 

!

testRemovingMethods

    | newMethod newClass |

    newClass:= RGClassDefinition named: #OrderedCollection.

    newMethod:= (RGMethodDefinition named: #add:)

                    parent: newClass;

                    protocol: 'adding';

                    sourceCode: 'add: newObject

                                    ^self addLast: newObject'.

    self assert: (newClass hasMethods not).

    newClass addMethod: newMethod.

    newClass addSelector: #size 

               classified: 'accessing' 

               sourced: 'size

                            ^ lastIndex - firstIndex + 1'.

    self assert: (newClass selectors = #(add: size)).

    newClass removeSelector: #join:.

    self assert: (newClass selectors = #(add: size)).

    newClass removeMethod: newMethod.

    self assert: ((newClass includesSelector: #add:) not).

    newClass removeSelector: #size.

    self assert: (newClass hasMethods not).

!

testStoreOn

    "self debug: #testStoreOn"

    | st |

    st := String streamContents: [:s |

        (Point) asRingDefinition storeOn: s.

        s contents].

    self assert: st = '(RGClassDefinition named: #Point)'.

    st := String streamContents: [:s |

        (Point class) asRingDefinition storeOn: s.

        s contents].

    self assert: st = '((RGMetaclassDefinition named: #''Point class'') baseClass:(RGClassDefinition named: #Point))'

!

testWithCategory

    | newClass |

    newClass:= (RGClassDefinition named:  #Object)

                        category: 'Kernel-Objects';

                        yourself.

    self assert: (newClass package isNil).

    self assert: (newClass category = 'Kernel-Objects').

!

testWithClassInstanceVariables

    | newClass metaClass classInstVar |

    newClass:= RGClassDefinition named:  #GenericException.

    newClass withMetaclass.

    metaClass:= newClass theMetaClass.

    metaClass addInstanceVariables: #(NotifierString).

    self assert: (metaClass instanceVariables size = 1).

    self assert: (metaClass instVarNames size = 1).

    self assert: (metaClass allInstVarNames size = 1).

    classInstVar:= metaClass instanceVariableNamed: #NotifierString.

    self assert: (classInstVar notNil).

    self assert: (classInstVar parent = metaClass).

    self assert: (classInstVar isClassInstanceVariable).

    self assert: (classInstVar isVariable).

    self assert: (classInstVar parentName = metaClass name).

    self assert: (classInstVar realClass = GenericException class).

    metaClass removeInstVarNamed: #NotifierString.

    self assert: (metaClass instanceVariables isEmpty).

    self assert: ((metaClass instanceVariableNamed: #NotifierString) isNil).

    "Modified: / 29-08-2015 / 10:28:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testWithClassVariables

    | newClass classVar |

    newClass:= (RGClassDefinition named: #Object)

                        addClassVariables: #(DependentsFields);

                        addClassVarNamed: #FakeVariable;

                        yourself.

    self assert: (newClass classVariables size = 2).

    self assert: (newClass classVarNames size = 2).

    self assert: (newClass allClassVarNames size = 2).  "no hierarchy"

    classVar:= newClass classVarNamed: #DependentsFields.

    self assert: (classVar notNil).

    self assert: (classVar isClassVariable).

    self assert: (classVar isVariable).

    self assert: (classVar parent = newClass).

    self assert: (classVar parentName == newClass name).

    self assert: (classVar realClass = Object).

    newClass withMetaclass.

    self assert: (newClass theMetaClass allClassVarNames size = 2).

    newClass removeClassVarNamed: #DependentsFields.

    self assert: (newClass classVariables size = 1).

!

testWithComment

    | newClass newComment |

    newClass:= RGClassDefinition named: #Object.

    newComment:= RGCommentDefinition new

                        parent: newClass;

                        content: 'This is a comment for test';

                        stamp: 'VeronicaUquillas 3/22/2011 14:51';

                        yourself.

    newClass comment: newComment.

    self assert: (newClass hasComment).

    self assert: (newClass hasStamp).

    self assert: (newClass = newComment parent).

    self assert: (newComment content = 'This is a comment for test').

    self assert: (newComment author = 'VeronicaUquillas').

    self assert: (newComment timeStamp = '3/22/2011 14:51' asDateAndTime).

    newClass comment: nil.

    self assert: (newClass hasComment not).

    newClass comment:  'This is a comment for test';

              stamp: 'VeronicaUquillas 3/22/2011 14:51'.

    self assert: (newClass comment isRingObject).

!

testWithDefaultNamespace

    | newClass |

    newClass:= RGClassDefinition named:  #Object.

    self assert: (newClass parent = Smalltalk globals).

    self assert: (newClass realClass = Object).

!

testWithInstanceVariables

    | newClass instVar |

    newClass:= RGClassDefinition named: #OrderedCollection.

    newClass addInstanceVariables: #(array firstIndex).

    newClass addInstVarNamed: #lastIndex.

    self assert: (newClass instanceVariables size = 3).

    self assert: (newClass instVarNames size = 3).

    self assert: (newClass allInstVarNames size = 3).

    instVar:= newClass instanceVariableNamed: #firstIndex.

    self assert: (instVar notNil).

    self assert: (instVar parent = newClass).

    self assert: (instVar isInstanceVariable).

    self assert: (instVar isVariable).

    self assert: (instVar parentName == newClass name).

    self assert: (instVar realClass = OrderedCollection).

    newClass removeInstVarNamed: #array.

    self assert: (newClass instanceVariables size = 2).

    self assert: ((newClass instanceVariableNamed: #array) isNil).

!

testWithPoolDictionaries

    | newClass poolVar |

    newClass:= (RGClassDefinition named:  #Text)

                        addSharedPoolNamed: #TextConstants;

                        yourself.

    self assert: (newClass sharedPools size = 1).

    self assert: (newClass sharedPoolNames size = 1).

    self assert: (newClass allSharedPools size = 1).  "no hierarchy"

    self assert: (newClass allSharedPoolNames size = 1).

    poolVar:= newClass sharedPoolNamed: #TextConstants.

    self assert: (poolVar notNil).

    self assert: (poolVar isPoolVariable).

    self assert: (poolVar isVariable).

    self assert: (poolVar parent = newClass).

    self assert: (poolVar parentName == newClass name).

    self assert: (poolVar realClass = Text).

    newClass withMetaclass.

    self assert: (newClass theMetaClass allSharedPoolNames size = 1).

    newClass removeSharedPoolNamed: #TextConstants.

    self assert: (newClass sharedPools isEmpty).

!

testWithProtocols

    | newMethod newClass |

    newClass:= RGClassDefinition named: #OrderedCollection.

    newMethod:= (RGMethodDefinition named: #add:)

                     parent: newClass;

                    protocol: 'adding'; 

                    sourceCode: 'add: newObject

                                    ^self addLast: newObject'.

    newClass addMethod: newMethod.

    newClass addProtocol: 'accessing'.

    self assert: (newClass hasProtocols).

    self assert: (newClass protocols size = 2).

    self assert: (newClass includesProtocol: 'accessing').

    self assert: ((newClass methodsInProtocol: 'adding') size = 1).

    self assert: ((newClass methodsInProtocol: 'accessing') isEmpty)

!

testWithSuperclass

    | newClass supClass  |

    supClass:= (RGClassDefinition named:  #Object)

                        superclassName: #ProtoObject;

                        yourself.

    self assert: (supClass hasSuperclass not).

    self assert: (supClass superclassName == #ProtoObject).   "kept as annotation"

    self assert: (supClass annotations size = 1).

    newClass := (RGClassDefinition named: #OrderedCollection) superclass: supClass.

    self assert: (newClass superclass = supClass).

    self assert: (newClass superclassName == #Object).

    self assert: (newClass withAllSuperclasses size = 2).

    self assert: (newClass allSuperclasses size = 1).

    self assert: (supClass subclasses size = 1).

    self assert: (supClass withAllSubclasses size = 2).

    self assert: (supClass allSubclasses size = 1).

! !