"{ Package: 'stx:libscm/mercurial' }"

HGTestCase subclass:#HGStXTests

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'SCM-Mercurial-Tests'

!

!HGStXTests class methodsFor:'documentation'!

documentation

"

    Tests for Mercurial-Smalltalk/X integration. Mapping packages

    to Mercurial repositories, commitning packages from image

    and so on...

    [author:]

        Jan Vrany <jan.vrany@fit.cvut.cz>

    [instance variables:]

    [class variables:]

    [see also:]

"

! !

!HGStXTests methodsFor:'running'!

loadPackage: packageId

    "A utility method to prepare a repository for package

     and load package from it"

    self repositoryNamed: (packageId copyReplaceAll:$: with:$/).

    Smalltalk loadPackage: packageId.

    "Created: / 16-11-2012 / 20:01:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

tearDown

    | classes methods |

    super tearDown.

    "Also, wipe out all mocks"

    classes := OrderedCollection new.

    methods := OrderedCollection new.

    Smalltalk allClassesDo:[:cls|

        (cls package notNil and:[cls package startsWith:'mocks']) ifTrue:[

            classes add: cls

        ] ifFalse:[

            cls methodsDo:[:m|(m package notNil and:[m package startsWith:'mocks']) ifTrue:[methods add: cls]].

            cls class methodsDo:[:m|(m package notNil and:[m package startsWith:'mocks']) ifTrue:[methods add: cls]].

        ]

    ].

    Class withoutUpdatingChangesDo:[ 

        classes do:[:cls|Smalltalk removeClass: cls].

        methods do:[:m|m mclass removeSelector: m selector]

    ].

"/    Delay waitForSeconds: 1.

    "Created: / 16-11-2012 / 19:00:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 21-11-2012 / 17:53:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_infrastructure

    "

        This is kind of meta-test that tests if the

        setUp/tearDown actually works. Especially, if

        no mock classes/methods are left in the image 

        after tearDown. Also, make sure that all

        HGPackageModels for mocks

    "

    | pm |

    self loadPackage:'mocks:hg/p1'.

    self assert: (Smalltalk at: #'mocks_hg_p1') notNil.

    pm := HGPackageModelRegistry packageNamed:'mocks:hg/p1'.

    self assert: pm notNil.

    self assert: ((HGPackageModelRegistry current instVarNamed:#packages) includesKey: #'mocks:hg/p1').

    pm := nil. 

    self cleanup.

    self assert: (Smalltalk at: #'mocks_hg_p1') isNil.

    self assert: repositories isNil.

    self assert: ((HGPackageModelRegistry current instVarNamed:#packages) includesKey: #'mocks:hg/p1') not.

    "Created: / 16-11-2012 / 19:25:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 20-11-2012 / 19:32:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 22-11-2012 / 15:31:54 / jv"

! !

!HGStXTests methodsFor:'tests - commit'!

test_commit_01

    "

        Simple commit

    "

    | repo pm ct |

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    self dumpRepositoryLog: repo. 

    self deny:   ((repo @ 1 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    (MockHGP1Bar compile:'zork ^ 1' classified:'test') package: MockHGP1Bar package.

    pm := HGPackageModel named: 'mocks:hg/p1'.

    ct := pm commitTask.

    ct message:'test_commit_01'.

    ct do.

    self dumpRepositoryLog: repo. 

    "

        repo workingCopy browse

    "

    self assert: ((repo @ 2 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    "Created: / 16-11-2012 / 18:51:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_commit_02a

    "

    Repeated commit

    "

    | repo pm ct |

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    pm := HGPackageModel named: 'mocks:hg/p1'.

    self dumpRepositoryLog: repo. 

    (MockHGP1Bar compile:'zork ^ 1' classified:'test') package: MockHGP1Bar package.

    self deny:   ((repo @ 1 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    ct := pm commitTask.

    ct message:'test_commit_02-1'.

    ct do.

    self dumpRepositoryLog: repo.

    self assert: ((repo @ 2 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    self assert: ((repo @ 2 ) parent1 == (repo @ 1 )).

    (MockHGP1Bar compile:'zork ^ 2' classified:'test') package: MockHGP1Bar package.

    ct := pm commitTask.

    ct message:'test_commit_02-2'.

    ct do.

    self dumpRepositoryLog: repo.

    self assert:  (repo @ 3) message = 'test_commit_02-2'.

    self assert: ((repo @ 3 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 2').

    self assert: ((repo @ 3 ) parent1 == (repo @ 2 )).

    "

    repo workingCopy browse

    "

    "Created: / 20-11-2012 / 19:33:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 22-11-2012 / 11:12:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_commit_02b

    "

    Repeated commit, remove the working copy between commits

    "

    | repo pm ct |

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    pm := HGPackageModel named: 'mocks:hg/p1'.

    (MockHGP1Bar compile:'zork ^ 1' classified:'test') package: MockHGP1Bar package.

    self deny:   ((repo @ 1 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    ct := pm commitTask.

    ct message:'test_commit_02-1'.

    ct do.

    self assert: ((repo @ 2 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    self assert: ((repo @ 2 ) parent1 == (repo @ 1 )).

    (MockHGP1Bar compile:'zork ^ 2' classified:'test') package: MockHGP1Bar package.

    pm workingCopy path recursiveRemove.

    ct := pm commitTask.

    ct message:'test_commit_02-2'.

    ct do.

    self assert: ((repo @ 3 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 2').

    self assert: ((repo @ 3 ) parent1 == (repo @ 2 )).

    "

    repo workingCopy browse

    "

    "Created: / 20-11-2012 / 19:35:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_commit_03a

    "

    Two images A, B working in parallel, commiting to same repo

    1) A: checkout, modify commit package (cs1)

    2) B: checkout, commit change         (cs2)

    2) A: modify, checkout                (cs3)

    The changeset cs3 should have cs1 as its parent1

    <skip>

    "

    | repo pmA ctA wcB s |

    "=== A modifies & commits =============================== "

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    self dumpRepositoryLog: repo.

    pmA := HGPackageModel named: 'mocks:hg/p1'.

    (MockHGP1Bar compile:'zork ^ 1' classified:'test') package: MockHGP1Bar package.

    self deny:   ((repo @ 1 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    ctA := pmA commitTask.

    ctA message:'test_commit_03a A-1'.

    ctA do.

    self dumpRepositoryLog: repo.

    self assert: ((repo @ 2 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    self assert: ((repo @ 2 ) parent1 == (repo @ 1 )).

    "=== B modifies & commits =============================== "

    wcB := repo workingCopy.

    s := ( wcB / 'abbrev.stc' ) appendStream.

    [ s nextPutLine:'# Modification '] ensure:[s close].

    wcB commit: 'test_commit_03a B-2'.

    self dumpRepositoryLog: repo.

    self assert: ((repo @ 3 ) parent1 == (repo @ 1 )).

    "=== A modifies & commits =============================== "    

    (MockHGP1Bar compile:'zork ^ 2' classified:'test') package: MockHGP1Bar package.

    ctA := pmA commitTask.

    ctA message:'test_commit_03a A-3'.

    ctA do.

    self dumpRepositoryLog: repo.

    self assert: ((repo @ 4 ) parent1 == (repo @ 2 )).

    "

    repo workingCopy browse

    "

    "Created: / 20-11-2012 / 19:45:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 22-11-2012 / 11:16:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_commit_03b

    "

    Two images A, B working in parallel, commiting to same repo

    1) A: checkout, modify commit package (cs1)

    2) B: checkout, commit change         (cs2)

    3) A: flushes its temp working copy

    4) A: modify, checkout                (cs3)

    The changeset cs3 should have cs1 as its parent1

    "

    | repo pmA ctA wcB s |

    "=== A modifies & commits =============================== "

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    pmA := HGPackageModel named: 'mocks:hg/p1'.

    (MockHGP1Bar compile:'zork ^ 1' classified:'test') package: MockHGP1Bar package.

    self deny:   ((repo @ 1 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    ctA := pmA commitTask.

    ctA message:'test_commit_03a A-1'.

    ctA do.

    self assert: ((repo @ 2 / 'MockHGP1Bar.st') contents asString includesString:'zork ^ 1').

    self assert: ((repo @ 2 ) parent1 == (repo @ 1 )).

    "=== B modifies & commits =============================== "

    wcB := repo workingCopy.

    s := ( wcB / 'abbrev.stc' ) appendStream.

    [ s nextPutLine:'# Modification '] ensure:[s close].

    wcB commit: 'test_commit_03a B-2'.

    self assert: ((repo @ 3 ) parent1 == (repo @ 1 )).

    "=== A flushed its working copy ========================= "

    pmA workingCopy path recursiveRemove.

    "=== A modifies & commits =============================== "    

    (MockHGP1Bar compile:'zork ^ 2' classified:'test') package: MockHGP1Bar package.

    ctA := pmA commitTask.

    ctA message:'test_commit_03a A-3'.

    ctA do.

    self assert: ((repo @ 4 ) parent1 == (repo @ 2 )).

    "

    repo workingCopy browse

    "

    "Created: / 20-11-2012 / 19:51:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 23-11-2012 / 23:11:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_commit_03c

    "

    Two images A, B working in parallel, commiting to same repo

                                                  (cs1) - base changeset

    2) B: checkout, modifu, commit change         (cs2)

    4) A: checkout, modify, commit change         (cs3)

    The changeset cs3 should have cs1 as its parent1

    "

    | repo pmA ctA wcB s |

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    pmA := HGPackageModel named: 'mocks:hg/p1'.

    "=== B modifies & commits =============================== "

    wcB := repo workingCopy.

    s := ( wcB / 'abbrev.stc' ) appendStream.

    [ s nextPutLine:'# Modification '] ensure:[s close].

    wcB commit: 'test_commit_03c B-1'.

    self assert: ((repo @ 2 ) parent1 == (repo @ 1 )).

    "=== A modifies & commits =============================== "    

    (MockHGP1Bar compile:'zork ^ 2' classified:'test') package: MockHGP1Bar package.

    ctA := pmA commitTask.

    ctA message:'test_commit_03c A-2'.

    ctA do.

    self assert: ((repo @ 3 ) parent1 == (repo @ 1 )).

    "

    repo workingCopy browse

    "

    "Created: / 20-11-2012 / 20:00:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 27-11-2012 / 22:16:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGStXTests methodsFor:'tests - misc'!

test_misc_fileReleaseAndRevisionNr

    "

    ProjectDefinition>>fileReleaseNr and ProjectDefinition>>fileRevisionNr

    are used to generate package.rc used on Windows.

    String returned must be an integer and must be a valid short value 

    - otherwise, BCC won't compile/link the library.

    If this test fail it means that implementation fileReleaseNr/fileRevisionNr

    is rubbish. As of 2012-11-23, it uses 'self revision' and expects

    (but does not check!!) the resulting string is in X.Y form. In mercurial,

    #revision returns node id (SHA1 hash string).

    It has to be fixed there!!

    "

    | repo |

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    self assert: ((Smalltalk at:#'mocks_hg_p1') fileReleaseNr allSatisfy:[:c|c isDigit]).

    self assert: ((Smalltalk at:#'mocks_hg_p1') fileReleaseNr asInteger < 16r7FFF).

    self assert: ((Smalltalk at:#'mocks_hg_p1') fileRevisionNr allSatisfy:[:c|c isDigit]).

    self assert: ((Smalltalk at:#'mocks_hg_p1') fileRevisionNr asInteger < 16r7FFF).

    "Created: / 23-11-2012 / 11:02:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_misc_hgRevision_01

    | repo |

    repo := self repositoryNamed: 'mocks/hg/p1'.

    Smalltalk loadPackage:'mocks:hg/p1'.

    self dumpRepositoryLog: repo. 

    self assert: (Smalltalk at:#'mocks_hg_p1') hgLogicalRevision asString = '1:e0bec585af86b3ee98047baa69530b2b2484c9c0'.

    "Created: / 23-11-2012 / 11:00:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGStXTests methodsFor:'utilities'!

cleanup

    "Wipeout all mock package leftovers. Could be used

     to simulate work from another fresh image"

    self tearDown

    "Created: / 20-11-2012 / 19:32:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGStXTests class methodsFor:'documentation'!

version_HG

    "Never, ever change this method. Ask JV or CG why"

    ^thisContext method mclass theNonMetaclass instVarNamed: #revision

! !