"{ Encoding: utf8 }"

"

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

Copyright (C) 2012-2015 Jan Vrany

Copyright (C) 2020 LabWare

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

Copyright (C) 2020 LabWare

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:'accessing'!

timeout

    "Returns a default timeout (sec) for the test.

     If nil is returned, no timeout enforced.

    Note that the timeout is set only when running under

    report runner, interactive tools does not use it"

    | method |

    method := self class lookupMethodFor: testSelector.

    method annotationsAt:#timeout: do:[:annotation|

         ^annotation arguments first

    ].

    ^120"sec - default timeout"

    "Created: / 13-02-2017 / 21:31:47 / vranyj1"

! !

!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').

    ((Smalltalk at:#MockHGP1Bar) compile:'zork ^ 1' classified:'test') package: (Smalltalk at:#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: / 27-06-2016 / 11:40:36 / 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 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>"

    "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 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: / 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