--- a/extensions.st Sat Aug 20 15:18:01 2011 +0200
+++ b/extensions.st Sat Aug 20 16:19:25 2011 +0200
@@ -1,38 +1,124 @@
"{ Package: 'stx:goodies/monticello' }"!
-!Behavior methodsFor:'* monticello'!
+!Annotation class methodsFor:'instance creation'!
+
+mctimestamp: aString
+
+ ^MCTimestampAnnotation new timestamp: aString
+
+ "Created: / 14-09-2010 / 15:35:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Behavior methodsFor:'*monticello-squeakCompatibility'!
+
+includesLocalSelector:aSymbol
+ ^ self localSelectors includes:aSymbol
+
+ "Created: / 26-08-2009 / 11:50:00 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Behavior methodsFor:'*monticello-squeakCompatibility'!
+
+localSelectors
+ ^ self methodDictionary collect:[:x | x selector asSymbol ]
+
+ "Created: / 26-08-2009 / 11:53:47 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Behavior methodsFor:'*monticello-squeakCompatibility'!
+
+traitCompositionString
+ ^ '{}'
+
+ "Created: / 26-08-2009 / 12:43:23 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Behavior methodsFor:'*monticello-squeakCompatibility'!
typeOfClass
- "Answer a symbol uniquely describing the type of the receiver"
+ "Answer a symbol uniquely describing the type of the receiver"
+ "self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]." "Very special!!"
+ self isBytes ifTrue:[^#bytes].
+ (self isWords and:[self isPointers not]) ifTrue:[^#words].
+ self isWeakPointers ifTrue:[^#weak].
+ self isVariable ifTrue:[^#variable].
+ ^#normal.
+
+ "Created: / 26-08-2009 / 12:45:50 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Boolean methodsFor:'*monticello-squeakCompatibility'!
+
+and: block1 and: block2
+ "Nonevaluating conjunction without deep nesting.
+ The receiver is evaluated, followed by the blocks in order.
+ If any of these evaluates as false, then return false immediately,
+ without evaluating any further blocks.
+ If all return true, then return true."
+
+ self ifFalse: [^ false].
+ block1 value ifFalse: [^ false].
+ block2 value ifFalse: [^ false].
+ ^ true
+
+ "Created: / 26-08-2009 / 11:47:54 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Boolean methodsFor:'*monticello-squeakCompatibility'!
- "/ self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!"
- (self isSubclassOf:#CompiledCode) ifTrue:[^#compiledMethod]. "Very special!!"
- self isBytes ifTrue:[^#bytes].
- (self isWords and:[self isPointers not]) ifTrue:[^#words].
- (self isLongs and:[self isPointers not]) ifTrue:[^#longs].
- self isWeakPointers ifTrue:[^#weak].
- "/ self isWeak ifTrue:[^#weak].
- self isVariable ifTrue:[^#variable].
- ^#normal.
+or: block1 or: block2 or: block3 or: block4
+ "Nonevaluating alternation without deep nesting.
+ The receiver is evaluated, followed by the blocks in order.
+ If any of these evaluates as true, then return true immediately,
+ without evaluating any further blocks.
+ If all return false, then return false."
+
+ self ifTrue: [^ true].
+ block1 value ifTrue: [^ true].
+ block2 value ifTrue: [^ true].
+ block3 value ifTrue: [^ true].
+ block4 value ifTrue: [^ true].
+ ^ false
+
+ "Created: / 26-08-2009 / 12:21:41 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Change methodsFor:'accessing'!
+
+mcDefinition
+
+ ^self objectAttributeAt: #mcDefinition
+
+ "Created: / 08-11-2010 / 17:56:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Change methodsFor:'accessing'!
+
+mcDefinition: aMCDefinition
+
+ ^self objectAttributeAt: #mcDefinition put: aMCDefinition
+
+ "Created: / 08-11-2010 / 17:56:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!Class methodsFor:'*monticello'!
asClassDefinition
- self isLoaded ifFalse:[
- ^ self autoload asClassDefinition
- ].
- ^ MCClassDefinition
- name: self name
- superclassName: self superclass name
- category: self category
- instVarNames: self instVarNames
- classVarNames: self classVarNames
- poolDictionaryNames: self poolDictionaryNames
- classInstVarNames: self class instVarNames
- type: self typeOfClass
- comment: (Smalltalk isSmalltalkX ifTrue:[self comment] ifFalse:[ self organization classComment asString ])
- commentStamp: (Smalltalk isSmalltalkX ifTrue:[nil] ifFalse:[self organization commentStamp])
+ ^ MCClassDefinition
+ name: self name
+ superclassName: self superclass name
+ traitComposition: self traitCompositionString
+ classTraitComposition: self class traitCompositionString
+ category: self category
+ instVarNames: self instVarNames
+ classVarNames: self classVarNames
+ poolDictionaryNames: self poolDictionaryNames
+ classInstVarNames: self class instVarNames
+ type: self typeOfClass
+ comment: (self organization classComment ? '') asStringWithSqueakLineEndings
+ commentStamp: self organization commentStamp
+
+ "Modified: / 12-09-2010 / 17:19:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!Class methodsFor:'*monticello'!
@@ -81,24 +167,808 @@
classInstanceVariableNames:''.
! !
+!ClassDescription methodsFor:'*monticello-squeakCompatibility'!
+
+classSide
+
+ ^ self theMetaclass
+
+ "Created: / 26-08-2009 / 11:44:51 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+ "Modified: / 12-09-2010 / 16:38:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!ClassDescription methodsFor:'*monticello-squeakCompatibility'!
+
+mcDefinition
+
+ |s|
+
+ s := WriteStream on:(String new).
+ self
+ basicFileOutDefinitionOn:s
+ withNameSpace:false
+ withPackage:false.
+ s position: s position - 1.
+
+ ^ s contents
+
+ "Created: / 11-09-2010 / 18:06:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!ClassDescription methodsFor:'*monticello-squeakCompatibility'!
+
+theNonMetaClass
+ ^ self
+
+ "Created: / 26-08-2009 / 11:39:08 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Metaclass methodsFor:'*monticello-squeakCompatibility'!
+
+theNonMetaClass
+ ^ myClass
+
+ "Created: / 26-08-2009 / 11:39:48 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
!Object methodsFor:'*monticello'!
isConflict
^false
! !
+!PackageInfo methodsFor:'comparing'!
+
+= other
+ ^ other species = self species and: [other packageName = self packageName]
+! !
+
+!PackageInfo methodsFor:'modifying'!
+
+addCoreMethod: aMethodReference
+ | category |
+ category := self baseCategoryOfMethod: aMethodReference.
+ aMethodReference actualClass organization
+ classify: aMethodReference methodSymbol
+ under: category
+ suppressIfDefault: false
+! !
+
+!PackageInfo methodsFor:'modifying'!
+
+addExtensionMethod: aMethodReference
+ | category |
+ category := self baseCategoryOfMethod: aMethodReference.
+ aMethodReference actualClass organization
+ classify: aMethodReference methodSymbol
+ under: self methodCategoryPrefix, '-', category
+! !
+
+!PackageInfo methodsFor:'modifying'!
+
+addMethod: aMethodReference
+ (self includesClass: aMethodReference class)
+ ifTrue: [self addCoreMethod: aMethodReference]
+ ifFalse: [self addExtensionMethod: aMethodReference]
+! !
+
+!PackageInfo methodsFor:'modifying'!
+
+baseCategoryOfMethod: aMethodReference
+ | oldCat oldPrefix tokens |
+ oldCat := aMethodReference category.
+ ({ 'as yet unclassified'. 'all' } includes: oldCat) ifTrue: [ oldCat := '' ].
+ tokens := oldCat findTokens: '*-' keep: '*'.
+
+ "Strip off any old prefixes"
+ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ifTrue: [
+ [ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ]
+ whileTrue: [ tokens removeFirst ].
+ oldPrefix := tokens removeFirst asLowercase.
+ [ (tokens at: 1 ifAbsent: [ '' ]) asLowercase = oldPrefix ]
+ whileTrue: [ tokens removeFirst ].
+ ].
+
+ tokens isEmpty ifTrue: [^ 'as yet unclassified'].
+ ^ String streamContents:
+ [ :s |
+ tokens
+ do: [ :tok | s nextPutAll: tok ]
+ separatedBy: [ s nextPut: $- ]]
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+category: categoryName matches: prefix
+ ^ categoryName notNil and: [categoryName = prefix or: [categoryName beginsWith: prefix, '-']]
+! !
+
+!PackageInfo methodsFor:'naming'!
+
+categoryName
+ |category|
+ category := self class category.
+ ^ (category endsWith: '-Info')
+ ifTrue: [category copyUpToLast: $-]
+ ifFalse: [category]
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+classesAndMetaClasses
+ | baseClasses |
+ baseClasses := self classes.
+ ^baseClasses , (baseClasses collect: [:c | c classSide])
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+coreCategoriesForClass: aClass
+ ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+coreMethods
+ ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+coreMethodsForClass:aClass
+ ^ ((aClass selectors difference: (aClass isMetaclass ifTrue:[#(#version_MC)] ifFalse:[#()]))
+ difference:((self foreignExtensionMethodsForClass:aClass)
+ collect:[:r | r methodSymbol ]))
+ asArray collect:[:sel | self referenceForMethod:sel ofClass:aClass ]
+
+ "Modified: / 14-09-2010 / 15:59:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+extensionCategoriesForClass: aClass
+ ^ aClass organization categories select: [:cat | self isYourClassExtension: cat]
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+extensionClasses
+ ^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+extensionMethods
+
+ ^ self externalBehaviors gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]
+
+ "Modified: / 18-08-2009 / 10:36:44 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 12-09-2010 / 18:57:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+extensionMethodsFromClasses: classes
+ ^classes
+ gather: [:class | self extensionMethodsForClass: class]
+! !
+
+!PackageInfo methodsFor:'modifying'!
+
+externalBehaviors
+ ^self externalClasses , self externalTraits
+! !
+
+!PackageInfo methodsFor:'dependencies'!
+
+externalCallers
+ ^ self
+ externalRefsSelect: [:literal | literal isKindOf: Symbol]
+ thenCollect: [:l | l].
+! !
+
+!PackageInfo methodsFor:'dependencies'!
+
+externalClasses
+ | myClasses |
+ myClasses := self classesAndMetaClasses asSet.
+ ^ Array streamContents:
+ [:s |
+ Object withAllSubclassesDo:
+ [:class |
+ (class programmingLanguage isSmalltalk not or:[myClasses includes: class]) ifFalse: [s nextPut: class]]]
+
+ "Modified: / 26-10-2010 / 23:46:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PackageInfo methodsFor:'naming'!
+
+externalName
+ ^ self packageName
+! !
+
+!PackageInfo methodsFor:'dependencies'!
+
+externalRefsSelect: selBlock thenCollect: colBlock
+ | pkgMethods dependents refs extMethods otherClasses otherMethods classNames |
+
+ classNames := self classes collect: [:c | c name].
+ extMethods := self extensionMethods collect: [:mr | mr methodSymbol].
+ otherClasses := self externalClasses difference: self externalSubclasses.
+ otherMethods := otherClasses gather: [:c | c selectors].
+ pkgMethods := self methods asSet collect: [:mr | mr methodSymbol].
+ pkgMethods removeAllFoundIn: otherMethods.
+
+ dependents := Set new.
+ otherClasses do: [:c |
+ c selectorsAndMethodsDo:
+ [:sel :compiled |
+ (extMethods includes: sel) ifFalse:
+ [refs := compiled literals select: selBlock thenCollect: colBlock.
+ refs do: [:ea |
+ ((classNames includes: ea) or: [pkgMethods includes: ea])
+ ifTrue: [dependents add: (self referenceForMethod: sel ofClass: c) -> ea]]]]].
+ ^ dependents
+! !
+
+!PackageInfo methodsFor:'dependencies'!
+
+externalSubclasses
+ | pkgClasses subClasses |
+ pkgClasses := self classes.
+ subClasses := Set new.
+ pkgClasses do: [:c | subClasses addAll: (c allSubclasses)].
+ ^ subClasses difference: pkgClasses
+! !
+
+!PackageInfo methodsFor:'modifying'!
+
+externalTraits
+ | behaviors |
+
+ ^ Array streamContents: [:s |
+ behaviors := self classesAndMetaClasses.
+ Smalltalk allTraits do: [:trait |
+ (behaviors includes: trait) ifFalse: [s nextPut: trait].
+ (behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]].
+! !
+
+!PackageInfo methodsFor:'dependencies'!
+
+externalUsers
+ ^ self
+ externalRefsSelect: [:literal | literal isVariableBinding]
+ thenCollect: [:l | l key]
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+foreignClasses
+ | s |
+ s := IdentitySet new.
+ self foreignSystemCategories
+ do: [:c | (SystemOrganization listAtCategoryNamed: c)
+ do: [:cl |
+ | cls |
+ cls := Smalltalk at: cl.
+ s add: cls;
+ add: cls class]].
+ ^ s
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+foreignExtensionCategoriesForClass: aClass
+ ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+foreignExtensionMethodsForClass: aClass
+ ^ (self foreignExtensionCategoriesForClass: aClass)
+ gather: [:cat | (aClass organization listAtCategoryNamed: cat)
+ collect: [:sel | self referenceForMethod: sel ofClass: aClass]]
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+foreignSystemCategories
+ ^ SystemOrganization categories
+ reject: [:cat | self includesSystemCategory: cat]
+! !
+
+!PackageInfo methodsFor:'comparing'!
+
+hash
+ ^ name hash
+
+ "Modified: / 12-09-2010 / 16:26:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+includesClass: aClass
+ ^ self includesSystemCategory: aClass theNonMetaClass category
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+includesClassNamed: aClassName
+ ^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+includesMethod: aSymbol ofClass: aClass
+ aClass ifNil: [^ false].
+ ^ self
+ includesMethodCategory: ((aClass organization categoryOfElement: aSymbol)
+ ifNil: [' '])
+ ofClass: aClass
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+includesMethodCategory: categoryName ofClass: aClass
+ ^ (self isYourClassExtension: categoryName)
+ or: [(self includesClass: aClass)
+ and: [(self isForeignClassExtension: categoryName) not]]
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+includesMethodCategory: categoryName ofClassNamed: aClass
+ ^ (self isYourClassExtension: categoryName)
+ or: [(self includesClassNamed: aClass)
+ and: [(self isForeignClassExtension: categoryName) not]]
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+includesMethodReference: aMethodRef
+ ^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+includesSystemCategory: categoryName
+ ^ self category: categoryName matches: self systemCategoryPrefix
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+isForeignClassExtension: categoryName
+ ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+isOverrideMethod: aMethodReference
+ ^ aMethodReference category endsWith: '-override'
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+isYourClassExtension: categoryName
+ ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]
+! !
+
+!PackageInfo methodsFor:'naming'!
+
+methodCategoryPrefix
+ "
+ ^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]
+ "
+ ^ '*', self packageName asLowercase
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+methods
+ ^ (self extensionMethods, self coreMethods) select: [:method |
+ method isValid
+ and: [method isLocalSelector]
+ and: [method methodSymbol isDoIt not]]
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+outsideClasses
+ ^ProtoObject withAllSubclasses difference: self classesAndMetaClasses
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+overrideMethods
+ ^ self extensionMethods select: [:ea | self isOvverideMethod: ea]
+! !
+
+!PackageInfo methodsFor:'naming'!
+
+packageName
+ "
+ ^ packageName ifNil: [packageName := self categoryName]
+ "
+ ^self categoryName
+! !
+
+!PackageInfo methodsFor:'naming'!
+
+packageName: aString
+
+ name := aString
+
+ "Modified: / 11-09-2010 / 13:25:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PackageInfo methodsFor:'testing'!
+
+referenceForMethod: aSymbol ofClass: aClass
+ ^ MethodReference new setStandardClass: aClass methodSymbol: aSymbol
+! !
+
+!PackageInfo methodsFor:'registering'!
+
+register
+ PackageOrganizer default registerPackage: self
+! !
+
+!PackageInfo methodsFor:'modifying'!
+
+removeMethod: aMethodReference
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+selectors
+ ^ self methods collect: [:ea | ea methodSymbol]
+! !
+
+!PackageInfo methodsFor:'listing'!
+
+systemCategories
+
+ ^(Smalltalk allClasses
+ collect: [:cls | cls category]
+ thenSelect:[:cat|cat startsWith: name]) asSet
+
+ "Modified: / 12-09-2010 / 16:35:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PackageInfo methodsFor:'naming'!
+
+systemCategoryPrefix
+ ^ self packageName
+! !
+
+!PackageInfo class methodsFor:'packages access'!
+
+allPackages
+ ^PackageOrganizer default packages
+! !
+
+!PackageInfo class methodsFor:'compatibility'!
+
+default
+ ^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]
+! !
+
+!PackageInfo class methodsFor:'documentation'!
+
+documentation
+"
+ This is a dummy, mimicry class to allow some squeak code to be filed in.
+ Its protocol is neither complete, nor fully compatible with the corresponding
+ squeak original class.
+"
+! !
+
+!PackageInfo class methodsFor:'testing'!
+
+existPackageNamed: aString
+ "
+ self existPackageNamed: 'PackageInfo'
+ self existPackageNamed: 'Zork'
+ "
+ ^ (self allPackages anySatisfy: [:each | each packageName = aString])
+
+! !
+
+!PackageInfo class methodsFor:'initialization'!
+
+initialize
+ self allSubclassesDo: [:ea | ea new register]
+! !
+
+!PackageInfo class methodsFor:'packages access'!
+
+registerPackageName: aString
+ ^ PackageOrganizer default registerPackageNamed: aString
+! !
+
+!ProjectDefinition class methodsFor:'code generation'!
+
+monticelloTimestamps_code
+
+ | methodsWithTimestamp |
+ methodsWithTimestamp := OrderedCollection new.
+
+ self classes do:[:cls|
+ cls methodsDo:[:mthd|
+ (mthd hasAnnotation: #mctimestamp:) ifTrue:[
+ methodsWithTimestamp add: mthd
+ ]
+ ].
+ ].
+ self extensionMethods do:[:mthd|
+ (mthd hasAnnotation: #mctimestamp:) ifTrue:[
+ methodsWithTimestamp add: mthd
+ ]
+ ].
+
+ ^self monticelloTimestamps_codeFor: methodsWithTimestamp
+
+ "
+ stx_goodies_mondrian_core monticelloTimestamps_code
+ "
+
+ "Created: / 09-11-2010 / 18:23:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!ProjectDefinition class methodsFor:'code generation'!
+
+monticelloTimestamps_codeFor: methods
+
+ | code |
+ code := String new writeStream.
+ code nextPutAll:'monticelloTimestamps
+
+ ^#('.
+ methods do:[:mthd|
+ code
+ tab; tab;
+ nextPut:$(;
+ nextPutAll: mthd mclass fullName;
+ space;
+ nextPutAll: mthd selector;
+ space;
+ nextPutAll: (mthd annotationAt: #mctimestamp:) timestamp storeString;
+ nextPut:$);
+ cr.
+ ].
+ code nextPutAll:'
+ )'.
+
+ ^code contents
+
+ "
+ stx_goodies_mondrian_core mcTimestamps_code
+ "
+
+ "Created: / 09-11-2010 / 18:27:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SequenceableCollection methodsFor:'*monticello-squeakCompatibility'!
+
+copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens
+ "Answer a copy of the receiver in which all occurrences of
+ oldSubstring have been replaced by newSubstring.
+ ifTokens (valid for Strings only) specifies that the characters
+ surrounding the recplacement must not be alphanumeric.
+ Bruce Simth, must be incremented by 1 and not
+ newSubstring if ifTokens is true. See example below. "
+
+ | aString startSearch currentIndex endIndex |
+ (ifTokens and: [(self isString) not])
+ ifTrue: [(self isKindOf: Text) ifFalse: [
+ self error: 'Token replacement only valid for Strings']].
+ aString := self.
+ startSearch := 1.
+ [(currentIndex := aString indexOfSubCollection: oldSubstring startingAt: startSearch)
+ > 0]
+ whileTrue:
+ [endIndex := currentIndex + oldSubstring size - 1.
+ (ifTokens not
+ or: [(currentIndex = 1
+ or: [(aString at: currentIndex-1) isAlphaNumeric not])
+ and: [endIndex = aString size
+ or: [(aString at: endIndex+1) isAlphaNumeric not]]])
+ ifTrue: [aString := aString
+ copyReplaceFrom: currentIndex
+ to: endIndex
+ with: newSubstring.
+ startSearch := currentIndex + newSubstring size]
+ ifFalse: [
+ ifTokens
+ ifTrue: [startSearch := currentIndex + 1]
+ ifFalse: [startSearch := currentIndex + newSubstring size]]].
+ ^ aString
+
+"Test case:
+ 'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true "
+
+ "Created: / 26-08-2009 / 12:40:34 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Smalltalk class methodsFor:'*monticello-squeakCompatibility'!
+
+hasClassNamed:aString
+ Symbol hasInterned:aString
+ ifTrue:[:aSymbol | ^ (self at:aSymbol ifAbsent:[ nil ]) isKindOf:Class ].
+ ^ false
+
+ "Created: / 26-08-2009 / 11:43:03 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
!Stream methodsFor:'*monticello'!
isMessageStream
^ false
! !
+!String methodsFor:'*monticello-squeakCompatibility'!
+
+asStringWithNativeLineEndings
+
+ ^self copyReplaceAll:Character return with: Character cr
+
+ "Created: / 12-09-2010 / 16:00:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 13-10-2010 / 17:27:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!String methodsFor:'*monticello-squeakCompatibility'!
+
+asStringWithSqueakLineEndings
+
+ ^self copyReplaceAll:Character cr with: Character return
+
+ "Created: / 12-09-2010 / 16:00:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 13-10-2010 / 17:28:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
!String methodsFor:'*monticello'!
extractNumber
^ ('0', self select: [:ea | ea isDigit]) asNumber
! !
+!String methodsFor:'*monticello-squeakCompatibility'!
+
+withSqueakLineEndings
+ "Answer a copy of myself in which all sequences of <CR><LF> or <LF> have been changed to <CR>"
+ | newText |
+ (self includes: Character lf) ifFalse: [ ^self copy ].
+ newText := self copyReplaceAll: String crlf with: String cr.
+ (newText asString includes: Character lf) ifFalse: [ ^newText ].
+ ^newText copyReplaceAll: String lf with: String cr asTokens: false.
+
+ "Created: / 26-08-2009 / 11:35:56 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!StringCollection methodsFor:'converting'!
+
+asStringWithNativeLineEndings
+
+ ^self asString
+
+ "Created: / 12-09-2010 / 15:58:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!StringCollection methodsFor:'converting'!
+
+asStringWithSqueakLineEndings
+
+ ^ self
+ asStringWith:Character return
+ from:1 to:(self size)
+ compressTabs:false
+ final:nil
+
+ "Created: / 12-09-2010 / 15:58:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Symbol methodsFor:'*monticello-squeakCompatibility'!
+
+isDoIt
+ ^ (self == #DoIt) or:[ self == #DoItIn: ].
+
+ "Created: / 26-08-2009 / 11:46:44 / Jaroslav Havlin <havlij6@fel.cvut.cz>"
+! !
+
+!Time class methodsFor:'*monticello'!
+
+fromString: aString
+ ^ self readFrom: (ReadStream on: aString).
+
+! !
+
+!Timestamp class methodsFor:'*monticello-instance creation'!
+
+fromMethodTimeStamp: aString
+ | stream |
+ stream := ReadStream on: aString.
+ stream skipSeparators.
+ stream skipTo: Character space.
+ ^self readFrom: stream.
+! !
+
+!Timestamp class methodsFor:'*monticello-instance creation'!
+
+fromString: aString
+ "Answer a new instance for the value given by aString.
+
+ Timestamp fromString: '1-10-2000 11:55:00 am'.
+ "
+
+ ^self readFrom: (ReadStream on: aString).
+! !
+
+!Timestamp class methodsFor:'*monticello-instance creation'!
+
+readFrom: stream
+ | date time |
+ stream skipSeparators.
+ date := Date readFrom: stream.
+ stream skipSeparators.
+ time := Time readFrom: stream.
+ ^self
+ date: date
+ time: time
+! !
+
+!Tools::NewSystemBrowser methodsFor:'menu actions-monticello'!
+
+projectMenuMonticelloCommit
+
+ | packageName package workingCopy |
+ packageName := self theSingleSelectedProject.
+ package := MCPackage named: packageName.
+ workingCopy := package workingCopy.
+ MCCommitDialog new
+ workingCopy: workingCopy;
+ open
+
+ "Created: / 14-09-2010 / 22:54:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Tools::NewSystemBrowser class methodsFor:'menu specs-monticello'!
+
+projectMonticelloMenu
+ "This resource specification was automatically generated
+ by the MenuEditor of ST/X."
+
+ "Do not manually edit this!! If it is corrupted,
+ the MenuEditor may not be able to read the specification."
+
+ "
+ MenuEditor new openOnClass:Tools::NewSystemBrowser andSelector:#projectMonticelloMenu
+ (Menu new fromLiteralArrayEncoding:(Tools::NewSystemBrowser projectMonticelloMenu)) startUp
+ "
+
+ <resource: #menu>
+
+ ^
+ #(Menu
+ (
+ (MenuItem
+ label: 'Commit'
+ itemValue: projectMenuMonticelloCommit
+ translateLabel: true
+ )
+ (MenuItem
+ label: '-'
+ )
+ (MenuItem
+ enabled: false
+ label: 'Not yet finished...'
+ translateLabel: true
+ )
+ )
+ nil
+ nil
+ )
+! !
+
!UndefinedObject methodsFor:'* monticello'!
typeOfClass
@@ -107,8 +977,67 @@
^#normal
! !
+!UserPreferences methodsFor:'accessing-monticello'!
+
+mcEnabled
+
+ ^self at: #mcEnabled ifAbsent: [true].
+
+ "Created: / 16-09-2010 / 09:44:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 16-09-2010 / 14:50:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!UserPreferences methodsFor:'accessing-monticello'!
+
+mcEnabled: aBoolean
+
+ self at: #mcEnabled put: aBoolean.
+
+ "Created: / 16-09-2010 / 09:44:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!UserPreferences methodsFor:'accessing-monticello'!
+
+mcRepositories
+
+ | repos |
+ repos := self at: #mcRepositories ifAbsent:[#()].
+ ^repos decodeAsLiteralArray
+
+ "
+ self mcRepositories: #()
+ "
+
+ "Created: / 16-09-2010 / 09:47:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 17-09-2010 / 11:45:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!UserPreferences methodsFor:'accessing-monticello'!
+
+mcRepositories: aCollection
+
+ | repos |
+ repos := aCollection literalArrayEncoding.
+ self at: #mcRepositories put:repos.
+ MCRepositoryGroup default flushRepositories.
+
+ "Created: / 16-09-2010 / 09:53:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 16-09-2010 / 13:56:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!VersionInfo methodsFor:'accessing'!
+
+timeStamp
+
+ ^Timestamp
+ fromDate: (Date fromString: date)
+ andTime: (Time fromString: time)
+
+ "Created: / 09-09-2010 / 15:20:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
!stx_goodies_monticello class methodsFor:'documentation'!
extensionsVersion_CVS
- ^ '$Header: /cvs/stx/stx/goodies/monticello/extensions.st,v 1.5 2010-10-30 16:21:27 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/goodies/monticello/extensions.st,v 1.6 2011-08-20 14:19:25 cg Exp $'
! !
\ No newline at end of file