--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SVN__WorkingCopy.st Wed Sep 23 18:48:19 2009 +0200
@@ -0,0 +1,720 @@
+"{ Package: 'cvut:stx/goodies/libsvn' }"
+
+"{ NameSpace: SVN }"
+
+Object subclass:#WorkingCopy
+ instanceVariableNames:'path repository branch packageClassesChanged
+ packageExtensionsChanged'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'SVN-Core'
+!
+
+!WorkingCopy class methodsFor:'documentation'!
+
+version_SVN
+ ^'$Id$'
+! !
+
+!WorkingCopy class methodsFor:'instance creation'!
+
+branch: aBranch path: aStringOrFilename
+
+ ^self new
+ branch: aBranch;
+ path: aStringOrFilename;
+ yourself
+
+ "Created: / 19-08-2009 / 11:25:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'accessing'!
+
+branch
+ branch ifNil:[
+ branch := BranchQuery new
+ repository: repository;
+ raiseRequest.
+ branch ifNil:[branch := self defaultBranch]].
+ ^ branch
+
+ "Created: / 31-03-2008 / 12:50:17 / janfrog"
+ "Modified: / 14-04-2008 / 12:44:25 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+branch: branchOrString
+
+ branch := branchOrString isString
+ ifFalse:
+ [repository := branchOrString repository.
+ branchOrString]
+ ifTrue:
+ [repository branches
+ detect:[:branch|branch path = branchOrString]
+ ifNone:[self error:'No such branch: ', branchOrString]].
+
+ "Created: / 31-03-2008 / 13:29:13 / janfrog"
+ "Modified: / 19-08-2009 / 11:22:45 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+commitMode
+
+ "UI Helper"
+
+ ^self packageClassesChanged ifTrue:[#full] ifFalse:[#fast]
+
+ "Created: / 13-08-2009 / 15:12:41 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+commitMode: mode
+
+ mode == #full ifTrue:[packageClassesChanged := true].
+
+ "Created: / 13-08-2009 / 15:13:08 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+defaultBranch
+
+ ^repository branches
+ detect:[:branch | branch isTrunk ]
+ ifNone:[self error: 'No branch!!'].
+
+ "Created: / 11-04-2008 / 13:15:34 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 14-04-2008 / 11:53:04 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+manager
+
+ ^repository manager
+
+ "Created: / 11-06-2009 / 13:33:17 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+package
+
+ ^repository package
+
+ "Created: / 31-03-2008 / 13:04:52 / janfrog"
+!
+
+packageClasses
+
+ ^self packageClassesWithPrivate reject:[:cls|cls owningClass notNil]
+
+ "Created: / 31-03-2008 / 13:06:13 / janfrog"
+ "Modified: / 23-03-2009 / 12:16:51 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageClassesChanged
+ packageClassesChanged :=
+ packageClassesChanged
+ or:[self computePackageClassesChanged].
+
+ ^ packageClassesChanged
+
+ "Modified: / 13-08-2009 / 10:21:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageClassesFiltered: classFilter
+
+ ^self packageClasses select: [:class|classFilter value: class].
+
+ "Created: / 23-03-2009 / 12:04:18 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageClassesWithPrivate
+
+ ^ProjectDefinition searchForClassesWithProject: self package
+
+ "Created: / 23-03-2009 / 12:06:58 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageClassesWithPrivateFiltered: classFilter
+
+ ^self packageClassesWithPrivate select: [:class|classFilter value: class].
+
+ "Created: / 23-03-2009 / 12:07:58 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageDefinition
+ ^ Smalltalk
+ at:(ProjectDefinition initialClassNameForDefinitionOf:self package)
+ asSymbol.
+
+ "Created: / 15-06-2009 / 12:41:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageExtensions
+
+ ^ProjectDefinition searchForExtensionsWithProject: self package
+
+ "Created: / 31-03-2008 / 13:06:13 / janfrog"
+ "Modified: / 11-04-2008 / 08:25:00 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageExtensionsChanged
+ packageExtensionsChanged :=
+ packageExtensionsChanged
+ or:[self computePackageExtensionsChanged].
+
+ ^ packageExtensionsChanged
+
+ "Modified: / 13-08-2009 / 10:22:23 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+packageExtensionsFiltered:aBlock
+
+ ^self packageExtensions select:aBlock
+
+ "Created: / 11-06-2009 / 13:37:27 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+path
+
+ ^ path
+
+ "Created: / 31-03-2008 / 12:42:42 / janfrog"
+ "Modified: / 21-08-2009 / 17:47:30 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+path:aStringOrFilename
+ path := aStringOrFilename asFilename.
+
+ "Created: / 31-03-2008 / 12:42:42 / janfrog"
+!
+
+pathBase
+
+ ^self manager workingCopyBase.
+
+ "Created: / 11-06-2009 / 13:32:54 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+repository
+ ^ repository
+
+ "Created: / 31-03-2008 / 12:42:22 / janfrog"
+!
+
+repository:aRepository
+ repository := aRepository.
+
+ "Created: / 31-03-2008 / 12:42:22 / janfrog"
+!
+
+url
+
+ ^branch url
+
+ "Created: / 31-03-2008 / 13:05:01 / janfrog"
+! !
+
+!WorkingCopy methodsFor:'accessing - change sets'!
+
+changeSet
+
+ ^self changeSetIgnoreAutoloaded: false
+
+ "Created: / 23-03-2009 / 18:57:16 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 12-08-2009 / 14:26:55 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+changeSetForContainer: containerName
+
+ ^ChangeSet fromStream:
+ (self containerReadStreamFor: containerName)
+
+ "Created: / 09-10-2008 / 20:21:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+changeSetForUpdate
+ |diffSet classesToRemove|
+
+ diffSet := self diffSetBetweenImageAndWorkingCopy.
+ classesToRemove := Set new.
+ SVN::ActivityNotification notify:'Computing update change set'.
+ "self = image, arg = revision"
+ ^(diffSet onlyInArg) ,
+ (diffSet changed collect:[:changePair | changePair second ])
+ , (diffSet onlyInReceiver
+ select:[:change | change isClassDefinitionChange ]
+ thenCollect:
+ [:change |
+ classesToRemove add:change className.
+ ClassRemoveChange className:change className])
+ , (diffSet onlyInReceiver
+ select:
+ [:change |
+ change isMethodDefinitionChange
+ and:[ (classesToRemove includes:change className) not ]]
+ thenCollect:
+ [:change |
+ MethodRemoveChange className:change className selector:change selector])
+
+ "Created: / 24-03-2009 / 08:17:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+changeSetIgnoreAutoloaded: ignoreAutoloaded
+
+ | containersToIgnore changeSet |
+
+ containersToIgnore :=
+ (self packageClassesFiltered:[:cls|cls isLoaded not])
+ collect:[:cls|repository containerNameForClass: cls].
+
+ changeSet := ChangeSet new.
+ self containers do:
+ [:container |
+ (containersToIgnore includes: container)
+ ifFalse:
+ [changeSet addAll:
+ (self changeSetForContainer: container)]].
+ ^changeSet
+
+ "Created: / 12-08-2009 / 14:26:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'accessing - containers'!
+
+containerFilenameFor: containerName
+
+ ^self path construct: containerName
+
+ "Created: / 09-10-2008 / 20:25:02 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+containerReadStreamFor: containerName
+
+ | containerFile containerStream |
+ containerFile := self containerFilenameFor: containerName.
+ OperatingSystem isMSWINDOWSlike
+ ifTrue:
+ ["
+ Dirty hack for MS Windows:
+ Windows do not allow me to open some files for the first
+ time (OpenError is raised). Second try after some time is usually OK.
+ I don't know why this happens. Claus, do you have any idea?
+ "
+ [ containerStream := containerFile readStream ]
+ on: OpenError do:
+ [Delay waitForMilliseconds: 100. "A magic constant here :-("
+ containerStream := containerFile readStream]]
+ ifFalse:
+ ["
+ Unix behaves pretty fine :-)
+ "
+ containerStream := containerFile readStream].
+
+ ^containerStream
+
+ "Created: / 09-10-2008 / 20:26:03 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+containerSuffixes
+
+ ^#(
+ 'st' "Smalltalk"
+ "/'js' "JavaScript - not yet supported"
+ "/'rb' "Ruby - not yet supported"
+ "/'pas' "Pascal - not yet supported"
+ )
+
+ "Created: / 23-03-2009 / 18:53:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+containerWriteStreamFor: containerName
+
+ ^(self containerFilenameFor: containerName) writeStream
+ eolMode: #nl;
+ yourself
+
+ "Created: / 09-10-2008 / 20:24:44 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+containerWriteStreamForExtensions
+
+ ^self containerWriteStreamFor: 'extensions.st'
+
+ "Created: / 09-10-2008 / 20:23:47 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+containers
+
+ ^(self path directoryContents
+ select:
+ [:container|self containerSuffixes anySatisfy:
+ [:suffix|container endsWith:suffix]]) asSet
+
+ "Created: / 23-03-2009 / 18:52:27 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 12-06-2009 / 21:44:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+containersToKeep
+
+ | containers |
+
+ containers := self packageClasses
+ collect:[:cls|self repository containerNameForClass: cls].
+ self packageExtensions isEmpty ifFalse:
+ [containers add: self repository containerNameForExtensions].
+ ^containers asSet.
+
+ "Created: / 12-06-2009 / 21:27:12 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+containersWriteStreamForClass:cls
+
+ ^self containerWriteStreamFor: (repository containerNameForClass:cls)
+
+ "Created: / 09-10-2008 / 20:23:59 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'accessing - diff sets'!
+
+diffSetBetweenImageAndWorkingCopy
+
+ | imageChangeSet revisionChangeSet |
+ imageChangeSet := ChangeSet forPackage: self package ignoreAutoloaded: true.
+ revisionChangeSet := self changeSetIgnoreAutoloaded: true.
+ ^imageChangeSet diffSetsAgainst: revisionChangeSet
+
+ "Created: / 24-03-2009 / 08:17:26 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 12-08-2009 / 14:32:03 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'accessing - tasks'!
+
+commitTask
+
+ ^CommitTask new workingCopy: self
+
+ "Created: / 23-03-2009 / 11:47:27 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+updateTask
+
+ ^UpdateTask new workingCopy: self
+
+ "Created: / 24-03-2009 / 15:13:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'commands'!
+
+cat: file
+
+ ^self cat: file revision: Revision head
+
+ "Created: / 19-04-2008 / 10:52:22 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 09-10-2008 / 20:16:53 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+cat: file revision: revision
+
+ ^self branch cat: file revision: revision
+
+ "Created: / 19-04-2008 / 10:52:34 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+checkout
+ |pkgDef|
+
+ pkgDef := self packageDefinition.
+ self
+ checkout:(pkgDef ifNotNil:[ pkgDef svnRevision ] ifNil:[ Revision head ])
+!
+
+checkout: revision
+
+ | checkoutInfo |
+
+ self synchronized:
+ [self ensurePathExists.
+ SVN::ActivityNotification notify:'Checking out ' , self package.
+ checkoutInfo := CheckoutCommand new
+ revision: revision;
+ workingCopy: self;
+ execute].
+ ^checkoutInfo
+
+ "Created: / 31-03-2008 / 12:57:58 / janfrog"
+ "Modified: / 21-08-2009 / 17:45:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+cleanup
+
+ self ensurePathExists.
+ self isValid ifFalse:[^self].
+ ^CleanupCommand new
+ workingCopy: self path;
+ execute.
+
+ "Created: / 08-11-2008 / 08:12:50 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+commit:message
+
+ ^self commitTask
+ message: message;
+ do
+
+ "Created: / 31-03-2008 / 13:11:15 / janfrog"
+ "Modified: / 07-04-2008 / 08:52:13 / janfrog"
+ "Modified: / 23-03-2009 / 11:48:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+log
+
+ ^self branch log
+
+ "Created: / 19-04-2008 / 10:52:53 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+log: aString
+
+ ^self branch log: aString
+
+ "Created: / 19-04-2008 / 10:53:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+revert
+
+ self ensurePathExists.
+ self isValid ifFalse:[^self checkout].
+ ^RevertCommand new
+ workingCopy: self path;
+ execute.
+
+ "Created: / 22-10-2008 / 16:46:18 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+revert: containers
+
+ | revertInfo |
+
+ self ensurePathExists.
+ self isValid ifFalse:[^self checkout].
+ self synchronized:
+ [revertInfo := RevertCommand new
+ workingCopy: self path;
+ paths: containers;
+ execute].
+ ^revertInfo
+
+ "Created: / 03-11-2008 / 21:20:38 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 07-11-2008 / 08:54:38 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+status
+
+ | status |
+ self ensureIsValid.
+ self synchronized:
+ [status := StatusCommand new
+ workingCopy: self;
+ execute].
+ ^status
+
+ "Created: / 11-04-2008 / 09:22:13 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 19-08-2009 / 14:35:49 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+update
+
+ | updateInfo |
+
+ self ensurePathExists.
+ self isValid ifFalse:[^self checkout].
+ self synchronized:
+ [updateInfo := UpdateCommand new
+ workingCopy: self path;
+ execute].
+ ^updateInfo
+
+ "Created: / 21-05-2008 / 09:44:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 19-08-2009 / 12:25:15 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'error reporting'!
+
+error
+
+ self error:'Unknown error'
+
+ "Created: / 31-03-2008 / 12:44:06 / janfrog"
+!
+
+error: aString
+
+ WCError raiseWith:#error: errorString:aString
+
+ "Created: / 31-03-2008 / 12:43:51 / janfrog"
+! !
+
+!WorkingCopy methodsFor:'private'!
+
+commited
+
+ packageExtensionsChanged := false.
+ packageClassesChanged := false.
+
+ "Created: / 13-08-2009 / 10:23:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+computePackageClassesChanged
+ "
+ Answers true iff package classes differs from
+ those listed in ProjectDefinition>>classNamesAndAttributes"
+
+ |listedClasses realClasses|
+
+ self packageDefinition ifNil:[^true].
+
+ listedClasses := self packageDefinition allClassNames.
+ realClasses := self packageClasses collect:[:cls | cls fullName ].
+ listedClasses size ~= realClasses size
+ ifTrue:[^ true].
+ (realClasses allSatisfy:[:realClass | listedClasses includes:realClass ])
+ ifFalse:[^true].
+ ^false
+
+
+
+
+ "
+ (CommitTask new package: 'stx:goodies/libsvn')
+ computePackageClassesChanged
+ (CommitTask new package: 'cvut:fel/smallruby')
+ computePackageClassesChanged
+
+ "
+
+ "Created: / 16-06-2009 / 10:08:28 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 18-08-2009 / 10:47:10 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+computePackageExtensionsChanged
+ "
+ Answers true iff package extension method differs from
+ those listed in ProjectDefinition>>extensionMethodNames"
+
+ |listedExtensions listedExtensionsDictionary realExtensions|
+
+ realExtensions := self packageExtensions.
+ listedExtensions := self packageDefinition
+ extensionMethodNames.
+ (listedExtensions size / 2) ~= realExtensions size ifTrue:[
+ ^ true
+ ].
+ listedExtensionsDictionary := Dictionary new.
+ listedExtensions
+ pairWiseDo:[:className :selector |
+ (listedExtensionsDictionary at:className
+ ifAbsentPut:[ OrderedCollection new ]) add:selector
+ ].
+ ^ (realExtensions
+ allSatisfy:[:mth |
+ (listedExtensionsDictionary includesKey:mth mclass name)
+ and:[ (listedExtensionsDictionary at:mth mclass name) includes:mth selector ]
+ ])
+ not
+
+ "
+ (CommitTask new package: 'stx:goodies/libsvn')
+ packageExtensionsHasChanged"
+
+ "Created: / 16-06-2009 / 10:11:01 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 13-08-2009 / 10:27:27 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+ensureIsValid
+
+ self isValid ifFalse:
+ [self checkout].
+ self isValid ifFalse:[self error:'Cannot create working copy']
+
+ "Created: / 08-04-2008 / 14:19:28 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+ensureMethodsHasAbsoluteSourceFiles
+
+ Smalltalk allClassesDo:
+ [:cls| | makeLocalSource |
+ makeLocalSource :=
+ [:mth|
+ mth package = self package ifTrue:
+ [mth makeSourceFileAbsolute]].
+ cls methodsDo: makeLocalSource.
+ cls class methodsDo: makeLocalSource].
+
+ "Created: / 21-08-2009 / 17:33:00 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+ensurePathExists
+
+ [path exists ifFalse:
+ [self ensureMethodsHasAbsoluteSourceFiles
+ path recursiveMakeDirectory
+ ]]
+ on: Smalltalk::Error do:[:ex|self error:'Cannot create working copy'].
+
+ "Created: / 08-04-2008 / 14:26:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 21-08-2009 / 17:46:05 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'private - file out'!
+
+fileOutClass:cls on:clsStream
+
+ cls
+ fileOutOn:clsStream
+ withTimeStamp:false
+ withInitialize:true
+ withDefinition:true
+ methodFilter:[:mth | mth package = self package ]
+
+ "Created: / 19-04-2008 / 09:58:11 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 11-06-2009 / 16:18:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+fileOutExtensionsOn:extensionsStream
+ extensionsStream
+ nextPutAll:'"$Id$"';
+ cr;
+ nextPutAll:'"{ Package: ''' , self package , ''' }"';
+ cr;
+ cr;
+ nextPut:$!!;
+ cr;
+ cr.
+ ^ self packageExtensions do:[:mth |
+ mth mclass fileOutMethod:mth on:extensionsStream
+ ]
+
+ "Created: / 19-04-2008 / 10:17:10 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 15-06-2009 / 11:55:26 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy methodsFor:'testing'!
+
+isValid
+
+ | svnMetadataDir |
+
+ svnMetadataDir := self path construct: '.svn'.
+ svnMetadataDir exists ifFalse:[^false].
+ (svnMetadataDir construct: 'entries') exists
+ ifFalse:[^false].
+ (svnMetadataDir construct: 'text-base') exists
+ ifFalse:[^false].
+
+ ^true
+
+ "Created: / 08-04-2008 / 14:17:03 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 16-07-2009 / 13:57:03 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!WorkingCopy class methodsFor:'documentation'!
+
+version
+ ^ '$Header$'
+! !