"
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 }"
TestCase subclass:#HGTestCase
instanceVariableNames:'repositories hgScmEnabled hgSettings scm scmPerPackage
tryLocalSourceFirst debug'
classVariableNames:'Verbose'
poolDictionaries:''
category:'SCM-Mercurial-Tests'
!
!HGTestCase 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
"
An anbstract base class for Mercurial tests
[author:]
Jan Vrany <jan.vrany@fit.cvut.cz>
[instance variables:]
[class variables:]
[see also:]
"
! !
!HGTestCase class methodsFor:'accessing'!
resources
^Array with: HGRepositoriesResource
"Created: / 19-09-2012 / 18:55:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 17-10-2012 / 13:01:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGTestCase class methodsFor:'testing'!
isAbstract
^self == HGTestCase
"Created: / 17-11-2012 / 11:00:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGTestCase methodsFor:'asserting'!
should: block raise: error withMessage: msg
<resource: #skipInDebuggersWalkBack>
^self should: block raise: error suchThat: [:ex|
ex description = msg
].
"Created: / 04-02-2013 / 11:13:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (format): / 04-02-2013 / 12:35:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGTestCase methodsFor:'debugging'!
dumpRepositoryLog: repo
^self dumpRepositoryLog: repo on: Transcript sender: thisContext sender
"Created: / 22-11-2012 / 11:08:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
dumpRepositoryLog: repo on: stream
self dumpRepositoryLog: repo on: stream sender: thisContext sender.
"Created: / 22-11-2012 / 11:10:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
dumpRepositoryLog: repo on: stream sender: sender
Verbose == true ifFalse:[ ^ self ].
stream cr.
stream nextPutAll: '+-- hg log '; nextPutAll: repo pathName; nextPutAll:' -- '; cr.
stream nextPutAll: '+-- sender: '; nextPutAll: sender printString ; nextPutAll:' -- '; cr.
(OperatingSystem getFullCommandOutputFrom:'hg log ', repo pathName) do:[:line|
stream nextPutAll:'| '; nextPutAll: line; cr.
].
stream nextPutAll: '+------------- '; cr.
"Created: / 22-11-2012 / 11:10:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGTestCase methodsFor:'private'!
performTest
HGAuthorQuery answer: (testSelector , ' <', testSelector , '@', self class name, '>') do:[
Class updateChangeFileQuerySignal answer: false do:[
| savedProject |
savedProject := Project current.
Project current: Project new.
[
super performTest.
] ensure:[
Project current: savedProject
].
]
].
"Created: / 30-09-2012 / 10:02:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-09-2013 / 01:22:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGTestCase methodsFor:'running'!
setUp
scm := false.
hgScmEnabled := HGSourceCodeManager shownInBrowserMenus.
"/ Save settings and reset to defaults, they will be restored in tearDown
hgSettings := Dictionary new.
#(hgCommand hgAutopush hgUseSharedRepositories) do:[:each |
hgSettings at: each put: (UserPreferences current at: each ifAbsent: [ nil ]).
].
UserPreferences current at: #hgUseSharedRepositories put: false.
scm := (Smalltalk at:#SourceCodeManager).
scmPerPackage := AbstractSourceCodeManager managerPerMatchingModuleDefinitions.
AbstractSourceCodeManager managerPerMatchingModuleDefinitions: scmPerPackage copy.
AbstractSourceCodeManager managerPerMatchingModuleDefinitions addFirst:
(AbstractSourceCodeManager::PackageAndManager package:'mocks:hg*' manager:HGSourceCodeManager).
scm isNil ifTrue:[ Smalltalk at: #SourceCodeManager put: HGSourceCodeManager].
tryLocalSourceFirst := Class tryLocalSourceFirst.
Class tryLocalSourceFirst:true.
HGSourceCodeManager shownInBrowserMenus: true.
repositories:= OrderedCollection new.
HGRepositoriesResource current setUpRepositoryDirectory.
debug := HGDebugFlags debug.
"/HGDebugFlags debug: false.
"Created: / 19-09-2012 / 19:01:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-02-2018 / 22:34:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
tearDown
"/ Restore settings
#(hgCommand hgAutopush hgUseSharedRepositories) do:[:each |
(hgSettings at: each) isNil ifTrue:[
UserPreferences current removeKey: each
] ifFalse:[
UserPreferences current at: each put: (hgSettings at: each).
].
].
HGSourceCodeManager shownInBrowserMenus: hgScmEnabled.
Smalltalk at: #SourceCodeManager put: scm.
AbstractSourceCodeManager managerPerMatchingModuleDefinitions: scmPerPackage.
Class tryLocalSourceFirst: tryLocalSourceFirst.
HGPackageWorkingCopyRegistry current flush:'mocks*'.
repositories := nil.
HGRepositoriesResource current tearDownRepositoryDirectory.
HGDebugFlags debug: debug.
"Created: / 19-09-2012 / 19:03:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 30-09-2012 / 05:26:48 / jv"
"Modified: / 07-02-2018 / 22:25:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGTestCase methodsFor:'utilities'!
repositoryNamed: nm
^self repositoryNamed: nm unpack: true
"Created: / 19-09-2012 / 19:04:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 14-01-2013 / 13:20:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
repositoryNamed: nm init: init
| dir |
dir := HGRepositoriesResource current directoryForRepositoryNamed: nm init: init.
repositories add: dir.
^HGRepository on: dir.
"Created: / 04-02-2013 / 11:04:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
repositoryNamed: nm revision: revision
^self repositoryNamed: nm unpack: true revision: revision
"Created: / 11-02-2014 / 11:09:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
repositoryNamed: nm unpack: unpack
| dir |
dir := HGRepositoriesResource current directoryForRepositoryNamed: nm unpack: unpack.
repositories add: dir.
^HGRepository on: dir.
"Created: / 14-01-2013 / 13:20:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
repositoryNamed: nm unpack: unpack revision: revision
| dir |
dir := HGRepositoriesResource current directoryForRepositoryNamed: nm unpack: unpack revision: revision.
repositories add: dir.
^HGRepository on: dir.
"Created: / 11-02-2014 / 11:09:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGTestCase class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
! !