"{ Encoding: utf8 }"

"

stx:libscm - a new source code management library for Smalltalk/X

Copyright (C) 2012-2015 Jan Vrany

This library is free software; you can redistribute it and/or

modify it under the terms of the GNU Lesser General Public

License as published by the Free Software Foundation; either

version 2.1 of the License.

This library is distributed in the hope that it will be useful,

but WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public

License along with this library; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

"

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

"{ NameSpace: Smalltalk }"

HGTestCase subclass:#HGStXTests

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'SCM-Mercurial-Tests'

!

!HGStXTests class methodsFor:'documentation'!

copyright

"

stx:libscm - a new source code management library for Smalltalk/X

Copyright (C) 2012-2015 Jan Vrany

This library is free software; you can redistribute it and/or

modify it under the terms of the GNU Lesser General Public

License as published by the Free Software Foundation; either

version 2.1 of the License.

This library is distributed in the hope that it will be useful,

but WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public

License along with this library; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

"

!

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: m]].

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

        ]

    ].

    Class withoutUpdatingChangesDo:[

        classes do:[:cls|cls removeFromSystem].

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

    ].

"/    Delay waitForSeconds: 1.

    "/ Also, wipe out cached sources...

    [

        (AbstractSourceCodeManager cacheDirectoryName asFilename / 'mocks') recursiveRemove

    ] on: Error do:[:ex|

        Delay waitForSeconds: 1.

        Error ignoreIn:[

            (AbstractSourceCodeManager cacheDirectoryName asFilename / 'mocks') recursiveRemove.

        ].

    ]

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

    "Modified: / 12-08-2014 / 20:57:51 / 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 := HGPackageWorkingCopyRegistry packageNamed:'mocks:hg/p1'.

    self assert: pm notNil.

    self assert: ((HGPackageWorkingCopyRegistry 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: ((HGPackageWorkingCopyRegistry current instVarNamed:#packages) includesKey: #'mocks:hg/p1') not.

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

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

    "Modified: / 05-03-2014 / 21:50:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGStXTests methodsFor:'tests - commit'!

test_commit_01

    "

        Simple commit

    "

    | repo pm ct |

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

    self assert: (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 := HGPackageWorkingCopy named: 'mocks:hg/p1'.

    ct := pm commitTask.

    self assert: ct isCommitingNewHead not.

    ct message:'test_commit_01'.

    ct do.

    self dumpRepositoryLog: repo.

    "

        repo workingCopy browse

    "

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

    self assert: (Smalltalk at:#mocks_hg_p1) hgLogicalRevision revno = 2.

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

    "Modified: / 05-03-2014 / 21:45:41 / 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 := HGPackageWorkingCopy 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: / 05-03-2014 / 21:49:04 / 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 := HGPackageWorkingCopy 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 temporaryWorkingCopy 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>"

    "Modified: / 05-03-2014 / 21:49:02 / 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 := HGPackageWorkingCopy 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.

    self assert: ctA isCommitingNewHead not.

    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.

    self assert: ctA isCommitingNewHead not.

    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: / 05-03-2014 / 21:48:58 / 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 := HGPackageWorkingCopy 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 temporaryWorkingCopy 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: / 05-03-2014 / 21:48:54 / 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 := HGPackageWorkingCopy 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: / 05-03-2014 / 21:48:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_commit_05a

    "

    Setup:

    Two repositories: package + upstream repo (package's default).

    1) checkout, modify.

    2) commit, setup autopush to default remote.

    Check whether remote gets updated/

    "

    | path upstreamP upstream repo pm ct |

    path := (self repositoryNamed: 'mocks/hg/p1') path.

    upstreamP := repositories add:(Filename newTemporaryDirectory).

    path moveTo: (upstreamP / 'upstream').

    upstream := HGRepository on: (upstreamP / 'upstream').

    repo := upstream cloneTo: path.

    self assert: (Smalltalk loadPackage: 'mocks:hg/p1').

    "=== modifyes & commits =============================== "

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

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

    ct := pm commitTask.

    ct message:'test_commit_05a 1'.

    ct remote: repo remoteDefault.

    ct do.

    self assert: (upstream @ 2) message = 'test_commit_05a 1'.

    "

    repo workingCopy browse

    "

    "Created: / 10-12-2012 / 01:58:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 05-03-2014 / 21:48:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

test_commit_05b

    "

    Setup:

    Two repositories: package + upstream repo (package's default).

    1) checkout, modify.

    2) modify & commit in upstream

    3) commit, setup autopush to default remote.

    Check that an exception is raised as commit would create new

    head.

    "

    | path upstreamP upstream repo wc pm ct s |

    path := (self repositoryNamed: 'mocks/hg/p1') path.

    upstreamP := repositories add:(Filename newTemporaryDirectory).

    path moveTo: (upstreamP / 'upstream').

    upstream := HGRepository on: (upstreamP / 'upstream').

    repo := upstream cloneTo: path.

    self assert: (Smalltalk loadPackage: 'mocks:hg/p1').

    "=== modify & commit into upstream ================== "

    wc := upstream workingCopy.

    [

        s := ( wc / 'MockHGP1Foo.st' ) appendStream.

        s nextPutLine: 'Just a comment'

    ] ensure:[