From bd0600a273fd64bbdcd9f47528f221f38d049efa Mon Sep 17 00:00:00 2001 From: Tim Felgentreff Date: Thu, 19 May 2011 12:09:43 +0200 Subject: [PATCH] 19 May 2011: tfel from Squeak: Ask before multiple commit messages are merged into 1 Conflicts: Core/GCCallout.st Core/GCGitWrapper.st Core/GCMapper.st Core/GCPackage.st Core/GCRegistry.st Extensions/MCWorkingCopyBrowser.st GST/GCGstConvertCommand.st GST/GCGstPackageWriter.st Morphic/GCRepositoryBrowser.st --- Core/GCCallout.st | 119 ++++---- Core/GCGitWrapper.st | 146 +++++---- Core/GCMapper.st | 240 +++++++-------- Core/GCPackage.st | 95 +++--- Core/GCRegistry.st | 467 +++++++++++++++-------------- Extensions/MCWorkingCopyBrowser.st | 82 +++-- GST/GCGstConvertCommand.st | 376 +++++++++++------------ GST/GCGstPackageWriter.st | 370 +++++++++++------------ Morphic/GCRepositoryBrowser.st | 353 ++++++++++------------ 9 files changed, 1071 insertions(+), 1177 deletions(-) diff --git a/Core/GCCallout.st b/Core/GCCallout.st index d907e19..0706443 100644 --- a/Core/GCCallout.st +++ b/Core/GCCallout.st @@ -1,82 +1,71 @@ -Object subclass: GCCallout [ - | localPath | - - - +Object subclass: #GCCallout + instanceVariableNames: 'localPath' + classVariableNames: 'CalloutDict GitBinaryPath' + poolDictionaries: '' + category: 'Gitocello-Core'! - CalloutDict := nil. - GitBinaryPath := nil. +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! - GCCallout class >> apiLinuxLibc5Callout: aCommand [ - +GCCallout class + instanceVariableNames: ''! + +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 15:36'! +apiLinuxLibc5Callout: aCommand - ^self externalCallFailed - ] + ^ self externalCallFailed ! ! - GCCallout class >> apiLinuxLibc6Callout: aCommand [ - +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 15:36'! +apiLinuxLibc6Callout: aCommand - ^self externalCallFailed - ] + ^ self externalCallFailed ! ! - GCCallout class >> apiMacOSXCallout: aCommand [ - - | errCode | +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 15:36'! +apiMacOSXCallout: aCommand - errCode := ExternalFunction getLastError. - ^errCode = 13 - ifTrue: - ["Unable to find function address. dylibs are not searched" - - self - error: 'Cannot call libSystem.dylib. + | errCode | + errCode := ExternalFunction getLastError. + ^ errCode = 13 "Unable to find function address. dylibs are not searched" + ifTrue: [self error: 'Cannot call libSystem.dylib. Please set "SqueakPluginsBuiltInOrLocalOnly" in your VM''s Info.plist to false'] - ifFalse: [self externalCallFailed] - ] + ifFalse: [self externalCallFailed]! ! - GCCallout class >> apiWindowsCallout: aCommand [ - +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 15:36'! +apiWindowsCallout: aCommand - ^self externalCallFailed - ] + ^ self externalCallFailed! ! - GCCallout class >> callout: aCommand [ - - ^(Smalltalk classNamed: 'OSProcess') ifNil: - [(self calloutDict at: SmalltalkImage current platformName asLowercase - ifAbsent: [[:cmd | self error: 'Callouts not implemented for your platform!']]) - value: aCommand] - ifNotNil: [:class | class waitForCommand: aCommand] - ] +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 16:21'! +callout: aCommand - GCCallout class >> calloutDict [ - - CalloutDict ifNil: - [CalloutDict := (Dictionary new) - at: 'unix' put: [:cmd | self linuxCallout: cmd]; - at: 'win32' put: [:cmd | self windowsCallout: cmd]; - at: 'mac os' put: [:cmd | self apiMacOSXCallout: cmd]; - yourself]. - ^CalloutDict - ] + ^ (Smalltalk classNamed: 'OSProcess') + ifNil: [(self calloutDict + at: SmalltalkImage current platformName asLowercase + ifAbsent: [[:cmd | self error: 'Callouts not implemented for your platform!!']]) + value: aCommand] + ifNotNilDo: [:class | class waitForCommand: aCommand].! ! - GCCallout class >> linuxCallout: aCommand [ - "Try with new libc6 and older libc5" +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 15:36'! +calloutDict - - [self apiLinuxLibc6Callout: aCommand] on: Error - do: [self apiLinuxLibc5Callout: aCommand] - ] + CalloutDict ifNil: [CalloutDict := Dictionary new + at: 'unix' put: [:cmd | self linuxCallout: cmd]; + at: 'win32' put: [:cmd | self windowsCallout: cmd]; + at: 'mac os' put: [:cmd | self apiMacOSXCallout: cmd]; + yourself]. + ^ CalloutDict! ! - GCCallout class >> windowsCallout: aCommand [ - "Escape newlines for Windows CmdLine" +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 15:36'! +linuxCallout: aCommand + "Try with new libc6 and older libc5" + [self apiLinuxLibc6Callout: aCommand] + on: Error + do: [self apiLinuxLibc5Callout: aCommand]! ! - +!GCCallout class methodsFor: 'callout' stamp: 'tfel 6/14/2010 15:36'! +windowsCallout: aCommand + "Escape newlines for Windows CmdLine" | escapedCommand | - escapedCommand := (aCommand copyReplaceAll: Character cr asString with: ' ') - copyReplaceAll: Character lf asString - with: ' '. - self apiWindowsCallout: escapedCommand - ] -] - + escapedCommand := ((aCommand + copyReplaceAll: Character cr asString with: ' ') + copyReplaceAll: Character lf asString with: ' '). + self apiWindowsCallout: escapedCommand.! ! diff --git a/Core/GCGitWrapper.st b/Core/GCGitWrapper.st index 8e7127f..4d4991e 100644 --- a/Core/GCGitWrapper.st +++ b/Core/GCGitWrapper.st @@ -1,100 +1,88 @@ -Object subclass: GCGitWrapper [ - | localPath | - - - - - CalloutDict := nil. - GitBinaryPath := nil. - - GCGitWrapper class >> gitBinaryPath [ - - - ^GitBinaryPath ifNil: ['git'] - ] - - GCGitWrapper class >> gitBinaryPath: aString [ - - GitBinaryPath := aString - ] - - add [ +Object subclass: #GCGitWrapper + instanceVariableNames: 'localPath' + classVariableNames: 'CalloutDict GitBinaryPath' + poolDictionaries: '' + category: 'Gitocello-Core'! + +!GCGitWrapper methodsFor: 'commands' stamp: 'tfel 9/8/2009 20:00'! +add "Just add all" + self gitCommand: 'add .'! ! - - self gitCommand: 'add .' - ] - - add: matchString [ +!GCGitWrapper methodsFor: 'commands' stamp: 'tfel 9/8/2009 20:00'! +add: matchString "Add using matchString" + self gitCommand: 'add ', matchString! ! - - self gitCommand: 'add ' , matchString - ] - - commit: commitMsg [ +!GCGitWrapper methodsFor: 'commands' stamp: 'tfel 6/14/2010 16:26'! +commit: commitMsg "Commit changes to the local repository" + self gitCommand: 'commit --allow-empty -m "', commitMsg, '"'! ! - - self gitCommand: 'commit --allow-empty -m "' , commitMsg , '"' - ] +!GCGitWrapper methodsFor: 'commands' stamp: 'mh 5/12/2010 17:03'! +dirChangeCommand + ^ SmalltalkImage current platformName asLowercase = 'win32' + ifTrue: ['cd "', self localPath, '" & ', (self localPath copyUpTo: $:) ,': & '] + ifFalse: ['cd "', self localPath, '";']. + ! ! - dirChangeCommand [ - - ^SmalltalkImage current platformName asLowercase = 'win32' - ifTrue: - ['cd "' , self localPath , '" & ' , (self localPath copyUpTo: $:) , ': & '] - ifFalse: ['cd "' , self localPath , '";'] - ] - - gitCommand: aCommandString [ +!GCGitWrapper methodsFor: 'commands' stamp: 'tfel 6/14/2010 15:37'! +gitCommand: aCommandString "Enter the local repository and run the 'git' command with the parameters" - - | command | - command := self dirChangeCommand , ' ' , self class gitBinaryPath , ' ' - , aCommandString. - GCCallout callout: command - ] - - init [ - - self gitCommand: 'init' - ] - - origin: aRemoteUrl [ - + command := self dirChangeCommand, ' ', self class gitBinaryPath, ' ', aCommandString. + GCCallout callout: command.! ! + +!GCGitWrapper methodsFor: 'commands' stamp: 'tfel 9/7/2009 01:03'! +init + + self gitCommand: 'init'! ! + +!GCGitWrapper methodsFor: 'commands' stamp: 'tfel 9/7/2009 03:29'! +origin: aRemoteUrl + self gitCommand: 'remote rm origin'. - self gitCommand: 'remote add origin ' , aRemoteUrl - ] + self gitCommand: 'remote add origin ', aRemoteUrl! ! - pull [ +!GCGitWrapper methodsFor: 'commands' stamp: 'TF 5/15/2010 17:59:40.669'! +pull "Avoid merging altogether for now" + self gitCommand: 'pull -s ours origin master'! ! + +!GCGitWrapper methodsFor: 'commands' stamp: 'tfel 9/6/2009 18:30'! +push - - self gitCommand: 'pull -s ours origin master' - ] + self gitCommand: 'push origin master'! ! - push [ - - self gitCommand: 'push origin master' - ] - localPath [ +!GCGitWrapper methodsFor: 'accessing' stamp: 'tfel 9/6/2009 23:10'! +localPath "Answer the value of localPath" - - ^localPath - ] + ^ localPath! ! - localPath: anObject [ +!GCGitWrapper methodsFor: 'accessing' stamp: 'tfel 9/6/2009 23:10'! +localPath: anObject "Set the value of localPath" - - localPath := anObject - ] -] + localPath := anObject! ! + +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! + +GCGitWrapper class + instanceVariableNames: ''! + +!GCGitWrapper class methodsFor: 'preferences' stamp: 'tfel 5/31/2010 15:38:12.485'! +gitBinaryPath + + + ^ GitBinaryPath ifNil: ['git'] +! ! + +!GCGitWrapper class methodsFor: 'preferences' stamp: 'tfel 5/31/2010 15:46:01.724'! +gitBinaryPath: aString + GitBinaryPath := aString.! ! diff --git a/Core/GCMapper.st b/Core/GCMapper.st index 4bf9cf1..a8b4b1c 100644 --- a/Core/GCMapper.st +++ b/Core/GCMapper.st @@ -1,10 +1,12 @@ -Object subclass: GCMapper [ - | systemOrganizer repoDir files package | - - - - - GCMapper class >> newFor: aPackage [ - - ^(self basicNew) - package: aPackage; - initialize; - yourself - ] - - GCMapper class >> extensionsFolder [ - - ^'Extensions' - ] - - createFolder: aSubfolder [ - - (File path: aSubfolder) exists - ifFalse: [repoDir createDirectory: aSubfolder] - ] - - fileOutCategory: aCategory [ - "This creates a sub-folder in the repository for the categories classes" + |- Class1.st! + + +!GCMapper methodsFor: 'fileOut' stamp: 'tfel 9/7/2009 20:27'! +createFolder: aSubfolder + + (repoDir directoryExists: aSubfolder) + ifFalse: [repoDir createDirectory: aSubfolder]! ! - +!GCMapper methodsFor: 'fileOut' stamp: 'tfel 9/7/2009 20:26'! +fileOutCategory: aCategory + "This creates a sub-folder in the repository for the categories classes" | subfolder | subfolder := (aCategory asString findBetweenSubStrs: '-') last. - (self package packageClasses - intersection: (systemOrganizer superclassOrder: aCategory)) ifNotEmptyDo: - [:arr | - self createFolder: subfolder. - arr do: [:each | self fileOutClass: each in: (repoDir / subfolder) name]] - ] - - fileOutClass: aClass in: aPath [ + self createFolder: subfolder. + (systemOrganizer superclassOrder: aCategory) do: [:each | + self + fileOutClass: each + in: (repoDir directoryNamed: subfolder) pathName]! ! + +!GCMapper methodsFor: 'fileOut' stamp: 'tfel 9/10/2009 11:53'! +fileOutClass: aClass in: aPath "This files out the class in the according sub-folder" - - | stream path | stream := WriteStream on: (String new: 100). - aClass - fileOutOn: stream - moveSource: false - toFile: 0. - path := aPath , Directory pathSeparator asString , aClass name. - self writeSourceCodeFrom: stream to: path - ] - - fileOutExtensions: extensionMethods [ - "For each extended class collect the extension Methods and file them out" + aClass fileOutOn: stream moveSource: false toFile: 0. + path := (aPath, FileDirectory pathNameDelimiter asString, aClass name). + self writeSourceCodeFrom: stream to: path! ! - +!GCMapper methodsFor: 'fileOut' stamp: 'tfel 9/10/2009 10:28'! +fileOutExtensions: extensionMethods + "For each extended class collect the extension Methods and file them out" | dict | - self createFolder: self class extensionsFolder. + self createFolder: 'Extensions'. dict := Dictionary new. - extensionMethods do: - [:each | + extensionMethods do: [:each | dict at: each classSymbol ifAbsentPut: OrderedCollection new. (dict at: each classSymbol) add: each methodSymbol]. - dict keysDo: - [:key | - | stream file | + dict keysDo: [:key || stream file | stream := WriteStream on: (String new: 1000). - file := (repoDir / 'Extensions') name , Directory pathSeparator asString - , key asString. - (dict at: key) do: - [:method | + file := (repoDir directoryNamed: 'Extensions') pathName, + FileDirectory pathNameDelimiter asString, + key asString. + (dict at: key) do: [:method | (Smalltalk classNamed: key) - printMethodChunk: method - withPreamble: true - on: stream - moveSource: false - toFile: 0]. - self writeSourceCodeFrom: stream to: file] - ] - - fileOutPackage [ - "Files out the entire package into a folder structure" + printMethodChunk: method withPreamble: true + on: stream moveSource: false toFile: 0]. + self writeSourceCodeFrom: stream to: file]! ! - +!GCMapper methodsFor: 'fileOut' stamp: 'tfel 9/10/2009 11:55'! +fileOutPackage + "Files out the entire package into a folder structure" | packageInfo | packageInfo := PackageInfo named: self packageName. - (packageInfo classes intersection: self package packageClasses) - collect: [:cls | cls category] - thenDo: [:category | self fileOutCategory: category]. - (packageInfo extensionMethods - select: [:m | self package packageClasses includes: m actualClass]) - ifNotEmptyDo: [:methods | self fileOutExtensions: methods] - ] - - writeSourceCodeFrom: aStream to: aFile [ - "This writes the source code and adds to files" + packageInfo systemCategories do: [:category | self fileOutCategory: category]. + packageInfo extensionMethods + ifNotEmpty: [self fileOutExtensions: packageInfo extensionMethods]. + ! ! - +!GCMapper methodsFor: 'fileOut' stamp: 'mh 5/12/2010 15:57'! +writeSourceCodeFrom: aStream to: aFile + "This writes the source code and adds to files" | converter f fileName | aStream contents isAsciiString - ifTrue: [converter := MacRomanTextConverter new] - ifFalse: [converter := UTF8TextConverter new]. - fileName := aFile , ($. printString , ($s printString , $t printString)). + ifTrue: [converter := MacRomanTextConverter new] + ifFalse: [converter := UTF8TextConverter new]. + fileName := aFile, (FileDirectory dot, FileStream st). f := MultiByteFileStream new open: fileName forWrite: true. - f ifNil: [^self error: 'Cannot open file']. + f ifNil: [^ self error: 'Cannot open file']. f lineEndConvention: #lf. - (converter isMemberOf: UTF8TextConverter) - ifTrue: - [f binary. - UTF8TextConverter writeBOMOn: f]. + (converter isMemberOf: UTF8TextConverter) + ifTrue: [f binary. + UTF8TextConverter writeBOMOn: f]. f text. f converter: converter. f nextPutAll: aStream contents. f close. - files add: fileName - ] - - files [ - - ^files - ] - - package [ - - ^package - ] - - package: anObject [ - - package := anObject - ] - - packageName [ - - ^package packageName - ] - - repoDir [ - - ^repoDir - ] - - repoDir: aFileDirectory [ - - aFileDirectory createDirectories. - repoDir := aFileDirectory - ] - - initialize [ - + files add: fileName! ! + + +!GCMapper methodsFor: 'accessing' stamp: 'tfel 9/10/2009 11:54'! +files + + ^ files! ! + +!GCMapper methodsFor: 'accessing' stamp: 'tfel 9/6/2009 20:33'! +packageName + "Answer the value of packageName" + + ^ packageName! ! + +!GCMapper methodsFor: 'accessing' stamp: 'tfel 9/6/2009 20:33'! +packageName: anObject + "Set the value of packageName" + + packageName := anObject! ! + +!GCMapper methodsFor: 'accessing' stamp: 'tfel 9/7/2009 02:29'! +repoDir + + ^ repoDir! ! + +!GCMapper methodsFor: 'accessing' stamp: 'tfel 9/13/2009 10:03'! +repoDir: aFileDirectory + + aFileDirectory assureExistence. + repoDir := aFileDirectory! ! + + +!GCMapper methodsFor: 'initialize-release' stamp: 'tfel 9/10/2009 11:55'! +initialize + super initialize. files := Set new. - systemOrganizer := Smalltalk organization - ] -] + systemOrganizer := Smalltalk organization! ! + +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! + +GCMapper class + instanceVariableNames: ''! + +!GCMapper class methodsFor: 'instance creation' stamp: 'tfel 9/6/2009 20:49'! +newFor: aPackage + ^ self basicNew + packageName: aPackage; + initialize; + yourself! ! diff --git a/Core/GCPackage.st b/Core/GCPackage.st index 26c660a..3654fd5 100644 --- a/Core/GCPackage.st +++ b/Core/GCPackage.st @@ -1,70 +1,65 @@ -Object subclass: GCPackage [ - | packageName packageClasses lastCommit | - - - - - GCPackage class >> newFor: aPackage [ - - ^(self new) - packageName: aPackage; - yourself - ] - - classes [ - "This converts, then sorts the class names, then finds the classes. Expensive, but run basically - only on intialization of the package and for the browser, which is slow anyway" - - +Object subclass: #GCPackage + instanceVariableNames: 'packageName packageClasses lastCommit' + classVariableNames: '' + poolDictionaries: '' + category: 'Gitocello-Core'! + +!GCPackage methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:31'! +classes + "This converts, then sorts the class names, then finds the classes. Expensive, but run basically + only on intialization of the package and for the browser, which is slow anyway" | packageInfo | - packageInfo := PackageInfo named: self packageName. - ^(((packageInfo classes asSet) - addAll: packageInfo extensionClasses; - yourself) collect: [:class | class name asString]) - asSortedCollection collect: [:className | Smalltalk classNamed: className] - ] - - lastCommit [ + packageInfo := (PackageInfo named: self packageName). + ^ ((packageInfo classes union: packageInfo extensionClasses) + collect: [:class | class name asString]) asSortedCollection + collect: [:className | Smalltalk classNamed: className]! ! + +!GCPackage methodsFor: 'accessing' stamp: 'tfel 9/20/2009 13:00'! +lastCommit "Answer the value of lastCommit" - - ^lastCommit - ] + ^ lastCommit! ! - lastCommit: anObject [ +!GCPackage methodsFor: 'accessing' stamp: 'tfel 9/20/2009 13:00'! +lastCommit: anObject "Set the value of lastCommit" - - lastCommit := anObject - ] + lastCommit := anObject! ! - packageClasses [ +!GCPackage methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:25'! +packageClasses "Answer the value of packageClasses" - packageClasses ifNil: [packageClasses := self classes]. - ^packageClasses - ] + ^ packageClasses! ! - packageClasses: anObject [ +!GCPackage methodsFor: 'accessing' stamp: 'tfel 9/20/2009 12:50'! +packageClasses: anObject "Set the value of packageClasses" - - packageClasses := anObject - ] + packageClasses := anObject! ! - packageName [ +!GCPackage methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:23'! +packageName "Answer the value of packageName" - - ^packageName - ] + ^ packageName! ! - packageName: anObject [ +!GCPackage methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:23'! +packageName: anObject "Set the value of packageName" - - packageName := anObject - ] -] + packageName := anObject! ! + +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! + +GCPackage class + instanceVariableNames: ''! + +!GCPackage class methodsFor: 'instance creation' stamp: 'tfel 9/20/2009 14:24'! +newFor: aPackage + ^ self new + packageName: aPackage; + yourself +! ! diff --git a/Core/GCRegistry.st b/Core/GCRegistry.st index 5c44297..c948f24 100644 --- a/Core/GCRegistry.st +++ b/Core/GCRegistry.st @@ -1,267 +1,276 @@ -Object subclass: GCRegistry [ - | git | - - - +I am well aware of the conversion to Gnu Smalltalk going on here, and I call the appropriate classes to do the conversion.! - GCRegistry class [ - | instance | - - ] - - Repositories := nil. - RepositoryRoot := nil. - - GCRegistry class >> at: aPackage [ - - ^self repositories at: aPackage - ] - - GCRegistry class >> createDirectoryStructure: aString [ - "Create the directory structure beneath the current image" - - - | repoDir | - repoDir := Directory working. - (aString findBetweenSubStrs: Directory pathSeparator asString) do: - [:each | - (File path: each) exists ifFalse: [repoDir createDirectory: each]. - repoDir := repoDir / each]. - ^repoDir - ] - - GCRegistry class >> initialize [ - - super initialize. - Smalltalk addToStartUpList: self. - self startUp. - self instance: nil - ] - GCRegistry class >> new [ - "One global Registry is enough" +!GCRegistry methodsFor: 'accessing' stamp: 'tfel 9/20/2009 13:01'! +at: aPackage - - ^self instance ifNil: [instance := super new] ifNotNil: [:foo | instance] - ] + ^ self repositories at: aPackage! ! - GCRegistry class >> startUp [ - - self - repositoryRoot: 'package-cache' , FileDirectory slash , 'git-repositories'. - self repositories keys copy do: - [:each | - (self repositoryRoot directoryNames includes: each) - ifFalse: [Repositories removeKey: each]] - ] - - GCRegistry class >> doesNotUnderstand: aMessage [ - - (self new respondsTo: aMessage selector) - ifTrue: - [^self instance perform: aMessage selector withArguments: aMessage arguments]. - ^super doesNotUnderstand: aMessage - ] - - GCRegistry class >> instance [ - - ^instance - ] - - GCRegistry class >> instance: anObject [ - - instance := anObject - ] - - GCRegistry class >> repositories [ - - Repositories ifNil: [Repositories := Dictionary new]. - ^Repositories - ] +!GCRegistry methodsFor: 'accessing' stamp: 'tfel 9/7/2009 03:33'! +repositories - GCRegistry class >> repositories: aDictionary [ - - Repositories := aDictionary - ] - - GCRegistry class >> repositoryRoot [ - "Return the FileDirectory" + ^ Repositories! ! - - ^RepositoryRoot - ] - GCRegistry class >> repositoryRoot: aStringOrDirectory [ - "Set the FileDirectory either directly or from String" - - - RepositoryRoot := aStringOrDirectory isString - ifTrue: [self createDirectoryStructure: aStringOrDirectory] - ifFalse: [self createDirectoryStructure: aStringOrDirectory name] - ] - - GCRegistry class >> tracksPackage: aPackageNameOrMCPackage [ - - ^(self repositories keys includes: aPackageNameOrMCPackage) - or: [self repositories keys includes: aPackageNameOrMCPackage name] - ] - - at: aPackage [ - - ^self repositories at: aPackage - ] - - repositories [ - - ^Repositories - ] - - commit: aPackage [ +!GCRegistry methodsFor: 'commands' stamp: 'tfel 5/17/2011 15:01:32.372'! +commit: aPackage "This is part of the class interface - try not to break it" - - - self - createFilesFor: aPackage; - run: #add - in: aPackage asString - with: #(); - run: #commit: - in: aPackage asString - with: (Array with: (self commitMessagesFor: aPackage)) - ] - - createRepositoryFor: aPackage [ + | lastCommit ancestors wc | + lastCommit := (GCRegistry at: aPackage) lastCommit. + wc := (MCPackage named: aPackage) workingCopy. + lastCommit ifNil: [lastCommit := (ListChooser + chooseItemFrom: wc ancestry breadthFirstAncestors + title: 'Please choose how far back you want to load and commit packages for import')]. + lastCommit ifNil: [^ self]. + ancestors := (wc ancestry allAncestorsOnPathTo: lastCommit) reverse. + ancestors + do: [:ancestor | + (wc repositoryGroup versionWithInfo: ancestor) + ifNil: [self inform: 'Cannot find a package for ', ancestor name, ' in the repositories.', + Character cr asString, 'I am continuing with the next version, ', + Character cr asString, 'and will combine the commit messages'] + ifNotNilDo: [:version | + version load. + self + createFilesFor: aPackage; + run: #add + in: aPackage asString + with: #(); + run: #commit: + in: aPackage asString + with: (Array with: (self commitMessagesFor: aPackage)) ]] + displayingProgress: [:ancestor | 'Commiting ', ancestor name]. +! ! + +!GCRegistry methodsFor: 'commands' stamp: 'tfel 9/20/2009 13:02'! +createRepositoryFor: aPackage "This will do everything in its power to commit that package to git!!" - - - (Repositories includesKey: aPackage) - ifFalse: - [Repositories add: aPackage -> (GCPackage newFor: aPackage). + (Repositories includesKey: aPackage) ifFalse: [ + Repositories add: (aPackage -> (GCPackage newFor: aPackage)). self createFilesFor: aPackage. self run: #init in: aPackage asString]. - self commit: aPackage - ] + self commit: aPackage! ! - dumpImage [ +!GCRegistry methodsFor: 'commands' stamp: 'tfel 4/25/2010 17:20:55.312'! +dumpImage "Dump all packages currently in the system" + (SmalltalkImage current organization categories + collect: [:c | c asString copyUpTo: $-]) asSet + do: [:package | GCRegistry new createRepositoryFor: package].! ! - - (SmalltalkImage current organization categories - collect: [:c | c asString copyUpTo: $-]) asSet - do: [:package | GCRegistry new createRepositoryFor: package] - ] - - pull: aPackage [ +!GCRegistry methodsFor: 'commands' stamp: 'TF 5/15/2010 17:59:51.201'! +pull: aPackage "This might be removed at some time in the future" + self run: #pull in: aPackage asString! ! - - self run: #pull in: aPackage asString - ] - - push: aPackage [ +!GCRegistry methodsFor: 'commands' stamp: 'tfel 9/8/2009 20:17'! +push: aPackage "This might be removed at some time in the future" + self run: #push in: aPackage asString! ! - - self run: #push in: aPackage asString - ] - - removeRepositoryFor: aPackage [ +!GCRegistry methodsFor: 'commands' stamp: 'tfel 9/8/2009 20:27'! +removeRepositoryFor: aPackage "This will not touch the filesystem, only our registry" + Repositories removeKey: aPackage ifAbsent: []! ! - - Repositories removeKey: aPackage ifAbsent: [] - ] - commitMessagesFor: aPackage [ +!GCRegistry methodsFor: 'monticello-helpers' stamp: 'tfel 5/19/2011 12:08:00.163'! +commitMessagesFor: aPackage + "Creates a git-commit-msg from the non-commited Monticello versions" + | messages ancestors | + ancestors := ((MCPackage named: aPackage) + workingCopy ancestry breadthFirstAncestors + copyUpTo: (self at: aPackage) lastCommit). + (ancestors size > 1 and: [self confirm: 'There are ', ancestors size, ' commits difference between the image and the Git repository. Should I commit all messages as one?']) + ifTrue: [messages := self commitMessagesForAncestors: ancestors] + ifFalse: [messages := self commitMessagesForAncestors: + (ancestors ifEmpty: {} ifNotEmpty: {ancestors at: 1})]. + (self at: aPackage) + lastCommit: ((MCPackage named: aPackage) workingCopy ancestry ancestors + ifEmpty: [nil] + ifNotEmpty: [:o | o first]). + ^ self escapeForBash: messages contents + ! ! + +!GCRegistry methodsFor: 'monticello-helpers' stamp: 'tfel 5/19/2011 12:04:50.313'! +commitMessagesForAncestors: aCollection "Creates a git-commit-msg from the non-commited Monticello versions" - - | cr messages | cr := Character lf asString. messages := WriteStream on: (String new: 100). - ((MCPackage named: aPackage) workingCopy ancestry breadthFirstAncestors - copyUpTo: (self at: aPackage) lastCommit) do: - [:next | - messages - nextPutAll: cr , cr , next date asString , ': ' , next author - , ' from Squeak: ' , next message]. - (self at: aPackage) - lastCommit: ((MCPackage named: aPackage) workingCopy ancestry ancestors - ifEmpty: [nil] - ifNotEmpty: [:o | o first]). - ^self escapeForBash: messages contents - ] - - escapeForBash: aString [ - - ^(((aString replaceAll: Character cr with: Character lf) replaceAll: $! - with: $.) replaceAll: $" with: $') - replaceAll: $$ - with: $S - ] - - storeVersion: aWorkingCopy [ - + aCollection do: [:next | + messages nextPutAll: cr, cr, next date asString, ': ', + next author, ' from Squeak: ', next message]. + ^ messages contents +! ! + +!GCRegistry methodsFor: 'monticello-helpers' stamp: 'tfel 9/10/2009 09:41'! +escapeForBash: aString + + ^ (((aString + replaceAll: Character cr with: Character lf) + replaceAll: $!! with: $.) + replaceAll: $" with: $') + replaceAll: $$ with: $S + ! ! + +!GCRegistry methodsFor: 'monticello-helpers' stamp: 'TF 5/15/2010 18:01:54.402'! +storeVersion: aWorkingCopy + | package | package := aWorkingCopy package name. - self - pull: package; - commit: package; - push: package - ] - - createFilesFor: aPackage [ - - | files pkg | - pkg := aPackage isString ifTrue: [self at: aPackage] ifFalse: [aPackage]. - files := (GCMapper newFor: pkg) - repoDir: RepositoryRoot / pkg packageName; - fileOutPackage; - files. - files do: - [:file | - GCGstConvertCommand - convert: file - from: 'squeak' - to: 'gst']. - (GCGstPackageWriter newFor: pkg) - repoDir: RepositoryRoot / pkg packageName; - fileOutPackageXml - ] - - initialize [ - + self + pull: package; + commit: package; + push: package. + ! ! + + +!GCRegistry methodsFor: 'fileOut' stamp: 'tfel 9/13/2009 11:56'! +createFilesFor: aPackage + "Create and convert source to Gnu Smalltalk syntax. Als create a package.xml" + | files | + files := (GCMapper newFor: aPackage) + repoDir: (RepositoryRoot directoryNamed: aPackage); + fileOutPackage; + files. + files do: [:file | GCGstConvertCommand convert: file from: 'squeak' to: 'gst']. + (GCGstPackageWriter newFor: aPackage) + repoDir: (RepositoryRoot directoryNamed: aPackage); + fileOutPackageXml! ! + + +!GCRegistry methodsFor: 'initialize-release' stamp: 'tfel 9/7/2009 03:32'! +initialize + super initialize. - git := GCGitWrapper new - ] + git := GCGitWrapper new! ! - run: aGitCommand in: aPackage [ - - self - run: aGitCommand - in: aPackage - with: (Array new: 0) - ] - run: aGitCommand in: aPackage with: anArgumentsArray [ +!GCRegistry methodsFor: 'helpers' stamp: 'tfel 9/8/2009 19:57'! +run: aGitCommand in: aPackage + + self run: aGitCommand in: aPackage with: (Array new: 0) + ! ! + +!GCRegistry methodsFor: 'helpers' stamp: 'tfel 9/8/2009 19:57'! +run: aGitCommand in: aPackage with: anArgumentsArray "Set the details we need and run" + git + localPath: RepositoryRoot pathName, + FileDirectory pathNameDelimiter asString, + aPackage; + perform: aGitCommand withArguments: anArgumentsArray + ! ! + +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! + +GCRegistry class + instanceVariableNames: 'instance'! + +!GCRegistry class methodsFor: 'accessing' stamp: 'tfel 9/20/2009 13:20'! +at: aPackage + + ^ self repositories at: aPackage! ! + + +!GCRegistry class methodsFor: 'class initialization' stamp: 'tfel 9/7/2009 03:42'! +createDirectoryStructure: aString + "Create the directory structure beneath the current image" + | repoDir | + repoDir := FileDirectory default. + (aString findBetweenSubStrs: FileDirectory pathNameDelimiter asString) + do: [:each | + (repoDir directoryExists: each) + ifFalse: [repoDir createDirectory: each]. + repoDir := repoDir directoryNamed: each]. + ^ repoDir! ! + +!GCRegistry class methodsFor: 'class initialization' stamp: 'mh 5/10/2010 15:27'! +initialize + + super initialize. + Smalltalk addToStartUpList: self. + self startUp. + self instance: nil.! ! + +!GCRegistry class methodsFor: 'class initialization' stamp: 'tfel 9/9/2009 13:44'! +new + "One global Registry is enough" + ^ self instance + ifNil: [instance := super new] + ifNotNil: [instance]! ! + +!GCRegistry class methodsFor: 'class initialization' stamp: 'mh 5/10/2010 15:28'! +startUp + + self + repositoryRoot: 'package-cache', FileDirectory slash, 'git-repositories'. + (self repositories keys copy do: [:each | + (self repositoryRoot directoryNames includes: each) + ifFalse: [Repositories removeKey: each]]).! ! + + +!GCRegistry class methodsFor: 'error handling' stamp: 'tfel 9/9/2009 13:43'! +doesNotUnderstand: aMessage + + (self new respondsTo: aMessage selector) + ifTrue: [^ self instance + perform: aMessage selector + withArguments: aMessage arguments]. + ^ super doesNotUnderstand: aMessage! ! + + +!GCRegistry class methodsFor: 'class variables' stamp: 'tfel 9/7/2009 03:31'! +instance + + ^ instance! ! + +!GCRegistry class methodsFor: 'class variables' stamp: 'tfel 9/7/2009 03:31'! +instance: anObject + + instance := anObject! ! + +!GCRegistry class methodsFor: 'class variables' stamp: 'mh 5/10/2010 15:23'! +repositories + + Repositories ifNil: [Repositories := Dictionary new]. + ^ Repositories ! ! + +!GCRegistry class methodsFor: 'class variables' stamp: 'tfel 9/7/2009 02:39'! +repositories: aDictionary + + Repositories := aDictionary! ! + +!GCRegistry class methodsFor: 'class variables' stamp: 'tfel 9/7/2009 03:09'! +repositoryRoot + "Return the FileDirectory" + ^ RepositoryRoot! ! + +!GCRegistry class methodsFor: 'class variables' stamp: 'tfel 9/7/2009 03:12'! +repositoryRoot: aStringOrDirectory + "Set the FileDirectory either directly or from String" + RepositoryRoot := aStringOrDirectory isString + ifTrue: [self createDirectoryStructure: aStringOrDirectory] + ifFalse: [self createDirectoryStructure: aStringOrDirectory pathName] + ! ! - - git - localPath: RepositoryRoot name , Directory pathSeparator asString - , aPackage; - perform: aGitCommand withArguments: anArgumentsArray - ] -] +!GCRegistry class methodsFor: 'class variables' stamp: 'tfel 9/10/2009 09:27'! +tracksPackage: aPackageNameOrMCPackage + ^ (self repositories keys includes: aPackageNameOrMCPackage) + or: [self repositories keys includes: aPackageNameOrMCPackage name]! ! - -Eval [ - GCRegistry initialize -] +GCRegistry initialize! diff --git a/Extensions/MCWorkingCopyBrowser.st b/Extensions/MCWorkingCopyBrowser.st index 3746d0e..d3df61d 100644 --- a/Extensions/MCWorkingCopyBrowser.st +++ b/Extensions/MCWorkingCopyBrowser.st @@ -1,59 +1,51 @@ -MCWorkingCopyBrowser extend [ - saveVersion [ - +!MCWorkingCopyBrowser methodsFor: '*gitocello-actions-override' stamp: 'TF 5/15/2010 18:00:57.1'! +saveVersion | repo | self canSave ifFalse: [^self]. self checkForNewerVersions ifFalse: [^self]. repo := self repository. - workingCopy newVersion ifNotNil: - [:v | + workingCopy newVersion ifNotNil: + [:v | (MCVersionInspector new version: v) show. Cursor wait showWhile: [repo storeVersion: v]. MCCacheRepository default cacheAllFileNamesDuring: [repo cacheAllFileNamesDuring: - [v allAvailableDependenciesDo: - [:dep | - (repo includesVersionNamed: dep info name) - ifFalse: [repo storeVersion: dep]]]]. - (GCRegistry tracksPackage: workingCopy package) - ifTrue: [GCRegistry storeVersion: workingCopy]] - ] + [v allAvailableDependenciesDo: + [:dep | + (repo includesVersionNamed: dep info name) + ifFalse: [repo storeVersion: dep]]]]. + (GCRegistry tracksPackage: workingCopy package) + ifTrue: [GCRegistry storeVersion: workingCopy]. + ].! ! - trackWithGit [ - - GCRegistry createRepositoryFor: workingCopy package name - ] +!MCWorkingCopyBrowser methodsFor: '*gitocello' stamp: 'tfel 9/10/2009 09:20'! +trackWithGit - untrackWithGit [ - - GCRegistry removeRepositoryFor: workingCopy package name - ] + GCRegistry createRepositoryFor: workingCopy package name! ! - workingCopyListMenu: aMenu [ - - workingCopy ifNil: [^aMenu]. - self fillMenu: aMenu - fromSpecs: #(#('add required package' #addRequiredPackage) #('clear required packages' #clearRequiredPackages) #('browse package' #browseWorkingCopy) #('view changes' #viewChanges) #('view history' #viewHistory) #('recompile package' #recompilePackage) #('revert package...' #revertPackage) #('unload package' #unloadPackage) #('delete working copy' #deleteWorkingCopy)). - (Smalltalk includesKey: #SARMCPackageDumper) - ifTrue: - [aMenu - add: 'make SAR' - target: self - selector: #fileOutAsSAR]. - (GCRegistry tracksPackage: workingCopy package) - ifFalse: - [aMenu - add: 'track with Git' - target: self - selector: #trackWithGit] - ifTrue: - [aMenu - add: 'untrack with Git' - target: self - selector: #untrackWithGit]. - ^aMenu - ] +!MCWorkingCopyBrowser methodsFor: '*gitocello' stamp: 'tfel 9/10/2009 09:24'! +untrackWithGit -] + GCRegistry removeRepositoryFor: workingCopy package name! ! +!MCWorkingCopyBrowser methodsFor: '*gitocello-morphic ui-override' stamp: 'tfel 9/10/2009 09:27'! +workingCopyListMenu: aMenu + workingCopy ifNil: [^ aMenu]. + self fillMenu: aMenu fromSpecs: + #(('add required package' #addRequiredPackage) + ('clear required packages' #clearRequiredPackages) + ('browse package' #browseWorkingCopy) + ('view changes' #viewChanges) + ('view history' #viewHistory) + ('recompile package' #recompilePackage) + ('revert package...' #revertPackage) + ('unload package' #unloadPackage) + ('delete working copy' #deleteWorkingCopy)). + (Smalltalk includesKey: #SARMCPackageDumper) ifTrue: [ + aMenu add: 'make SAR' target: self selector: #fileOutAsSAR + ]. + (GCRegistry tracksPackage: workingCopy package) + ifFalse: [aMenu add: 'track with Git' target: self selector: #trackWithGit] + ifTrue: [aMenu add: 'untrack with Git' target: self selector: #untrackWithGit]. + ^aMenu! ! diff --git a/GST/GCGstConvertCommand.st b/GST/GCGstConvertCommand.st index 3b7d84b..4ae96c4 100644 --- a/GST/GCGstConvertCommand.st +++ b/GST/GCGstConvertCommand.st @@ -1,215 +1,199 @@ -Object subclass: GCGstConvertCommand [ - - - - - GstConvertBinaryPath := nil. - RunGstConvert := nil. - - GCGstConvertCommand class >> allMethodsIn: aCategory [ - - ^((self class methodDictionary asSet - select: [:msg | msg methodCategory asString = aCategory]) - collect: [:each | each selector]) asArray - ] - - GCGstConvertCommand class >> classNames [ - - ^ - {'Float' -> 'FloatD'. - 'BlockContext' -> 'BlockClosure'. - 'MessageSend' -> 'DirectedMessage'. - 'DateAndTime' -> 'DateTime'. - 'UnhandledError' -> 'SystemExceptions.UnhandledException'} - ] - - GCGstConvertCommand class >> methodNames [ - - ^ - {'Date current' -> 'Date today'. - 'TimeStamp current' -> 'DateTime now'. - 'FileDirectory pathNameDelimiter' -> 'Directory pathSeparator'. - 'FileDirectory default' -> 'Directory working'. - '(FileDirectory deleteFilePath: ``@arg2)' -> '(File remove: ``@arg2)'. - '(FileDirectory localNameFor: ``@arg2)' - -> '(FilePath stripPathFrom: ``@arg2)'. - '(``@object recursiveDelete)' -> '(``@object all remove)'. - '(``@object pathName)' -> '(``@object name)'. - '(``@object containingDirectory)' -> '(``@object parent)'. - '(``@object assureExistence)' -> '(``@object createDirectories)'. - '(``@object fileExists: ``@arg2)' -> '(``@object / ``@arg2) exists'. - '(FileDirectory on: ``@arg2)' -> '(``@arg2 asFile)'. - '(``@object directoryNamed: ``@arg2)' -> '(``@object / ``@arg2)'. - '(``@object readOnlyFileNamed: ``@arg2)' - -> '(``@object / ``@arg2) readStream'. - '(``@object forceNewFileNamed: ``@arg2)' - -> '(``@object / ``@arg2) writeStream'. - '(``@object allSubInstancesDo: ``@arg2)' - -> '(``@object allSubinstancesDo: ``@arg2)'. - '(``@object newFrom: ``@arg2)' -> '(``@object from: ``@arg2)'. - '((``@object methodClass organization categoryOfElement: ``@object selector))' - -> '(``@object methodCategory)'} - ] - - GCGstConvertCommand class >> statements [ - - ^ - {'(``@object ifNil: ``@arg ifNotNil: [ | `@t2 | `@.s2 ])' - -> '(``@object ifNil: ``@arg ifNotNil: [ :foo || `@t2 | `@.s2 ])'. - '(``@object ifNotNil: [ | `@t2 | `@.s2 ] ifNil: ``@arg)' - -> '(``@object ifNotNil: [ :foo || `@t2 | `@.s2 ] ifNil: ``@arg)'. - '(``@object ifNotNil: [ | `@t2 | `@.s2 ])' - -> '(``@object ifNotNil: [ :foo || `@t2 | `@.s2 ])'} - ] - - GCGstConvertCommand class >> writeRules: someRules to: aStream [ - - someRules do: - [:each | - aStream - nextPutAll: '-r'; - nextPut: $'; - nextPutAll: (each printString copyWithout: $'); - nextPut: $'; - nextPut: Character space] - ] - - GCGstConvertCommand class >> convert: aFilepath from: input to: output [ - - self runGstConvert - ifTrue: - [self - basicConvert: aFilepath - from: input - to: output] - ] - - GCGstConvertCommand class >> gstBidirectional [ - "Reverse all bidirectional rules to apply them for squeak -> gst conversion" +Object subclass: #GCGstConvertCommand + instanceVariableNames: '' + classVariableNames: 'GstConvertBinaryPath RunGstConvert' + poolDictionaries: '' + category: 'Gitocello-GST'! +!GCGstConvertCommand commentStamp: 'tfel 9/10/2009 11:48' prior: 0! +I am used for converting a Squeak source file to Gnu Smalltalk syntax using the gst-convert tool with the options found at http://smalltalk.gnu.org/faq/169! - - ^(self allMethodsIn: 'bidirectional-rules') inject: OrderedCollection new - into: - [:list :method | - (list asSet) - addAll: ((self perform: method) collect: [:each | each value -> each key]); - yourself] - ] - - GCGstConvertCommand class >> gstNewline [ - - ^'\\n' - ] - - GCGstConvertCommand class >> squeakNewline [ - - ^'\\r' - ] - - GCGstConvertCommand class >> squeakBidirectional [ - "Find all bidirectional rules to include them in the conversion" - - ^(self allMethodsIn: 'bidirectional-rules') inject: OrderedCollection new - into: - [:list :method | - (list asSet) - addAll: (self perform: method); - yourself] - ] - - GCGstConvertCommand class >> squeakClassNames [ - - ^ - {'TimeStamp' -> 'DateTime'. - 'ProtoObject' -> 'nil'} - ] - - GCGstConvertCommand class >> squeakMethodNames [ - - ^ - {'(``@object caseInsensitiveLessOrEqual: ``@arg2)' - -> '(``@object <= ``@arg2)'. - '(``@object isZero)' -> '(``@object = 0)'. - 'FileDirectory dot' -> '($. printString)'. - '(``@object directoryExists: ``@arg2)' -> '(File path: ``@arg2) exists'. - '(``@object union: ``@arg1)' - -> '(``@object asSet addAll: ``@arg1; yourself)'. - 'FileStream st' -> '($s printString, $t printString)'. - '(``@object beginsWith: ``@arg2)' -> '(``@object startsWith: ``@arg2)'. - '(``@object ifNil: ``@arg1 ifNotNilDo: ``@arg2)' - -> '(``@object ifNil: ``@arg1 ifNotNil: ``@arg2)'. - '(``@object ifNotNilDo: ``@arg2 ifNil: ``@arg1)' - -> '(``@object ifNotNil: ``@arg2 ifNil: ``@arg1)'. - '(``@object ifNotNilDo: ``@arg2)' -> '(``@object ifNotNil: ``@arg2)'. - '(``@object doIfNotNil: ``@arg2)' -> '(``@object ifNotNil: ``@arg2)'} - ] - - GCGstConvertCommand class >> squeakStatements [ - - ^ - {'(``@object and: ``@arg1 and: ``@arg2)' - -> '((``@object and: ``@arg1) and: ``@arg2)'} - ] - - GCGstConvertCommand class >> basicConvert: aFilepath from: input to: output [ - "see http://smalltalk.gnu.org/faq/169 for info on gst-convert command-line" +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! + +GCGstConvertCommand class + instanceVariableNames: ''! + +!GCGstConvertCommand class methodsFor: 'private' stamp: 'tfel 9/14/2009 01:01'! +allMethodsIn: aCategory + + ^ ((self class methodDictionary asSet select: [:msg | + (msg methodClass organization categoryOfElement: msg selector) asString = aCategory]) + collect: [:each | each selector]) asArray! ! - + +!GCGstConvertCommand class methodsFor: 'callouts' stamp: 'tfel 6/14/2010 17:36'! +basicConvert: aFilepath from: input to: output + "see http://smalltalk.gnu.org/faq/169 for info on gst-convert command-line" | stream filename | stream := WriteStream on: (String new: 1000). - stream nextPutAll: self gstConvertBinaryPath , ' -f ' , input , ' '. "-F ', output, ' '." - (self allMethodsIn: input , '-to-' , output , '-rules') - do: [:method | self writeRules: (self perform: method) to: stream]. - stream nextPutAll: ' "' , aFilepath , '" "' , aFilepath , '.converted"'. + stream nextPutAll: self gstConvertBinaryPath, ' -f ', input, ' '."-F ', output, ' '." + (self allMethodsIn: input, '-to-', output, '-rules') + do: [:method | self writeRules: (self perform: method) to: stream]. + stream nextPutAll: ' "', aFilepath, '" "', aFilepath, '.converted"'. GCCallout callout: stream contents. - filename := FilePath stripPathFrom: aFilepath. - File remove: aFilepath. - (FileDirectory forFileName: aFilepath) rename: filename , '.converted' - toBe: filename - ] - - GCGstConvertCommand class >> flip: aString with: anotherString on: aFilepath [ - + filename := FileDirectory localNameFor: aFilepath. + FileDirectory deleteFilePath: aFilepath. + (FileDirectory forFileName: aFilepath) + rename: filename, '.converted' toBe: filename.! ! + +!GCGstConvertCommand class methodsFor: 'callouts' stamp: 'tfel 6/14/2010 17:18'! +flip: aString with: anotherString on: aFilepath + | filename | - (GCCallout - callout: 'tr ' , aString , ' ' , anotherString , ' < "' , aFilepath - , '" > "' , aFilepath - , '.converted"') - = 0 - ifTrue: - [filename := FilePath stripPathFrom: aFilepath. - File remove: aFilepath. - (FileDirectory forFileName: aFilepath) rename: filename , '.converted' - toBe: filename] - ] - - GCGstConvertCommand class >> gstConvertBinaryPath [ - + (GCCallout callout: 'tr ', aString, ' ', anotherString, ' < "', aFilepath, + '" > "', aFilepath, '.converted"') = 0 ifTrue: [ + filename := FileDirectory localNameFor: aFilepath. + FileDirectory deleteFilePath: aFilepath. + (FileDirectory forFileName: aFilepath) + rename: filename, '.converted' toBe: filename].! ! + + +!GCGstConvertCommand class methodsFor: 'bidirectional-rules' stamp: 'tfel 9/14/2009 01:10'! +classNames + + ^ { 'Float' -> 'FloatD' . + 'BlockContext' -> 'BlockClosure' . + 'MessageSend' -> 'DirectedMessage' . + 'DateAndTime' -> 'DateTime' . + 'UnhandledError' -> 'SystemExceptions.UnhandledException' . + }! ! + +!GCGstConvertCommand class methodsFor: 'bidirectional-rules' stamp: 'tfel 9/14/2009 01:13'! +methodNames + + ^ { 'Date current' -> 'Date today' . + 'TimeStamp current' -> 'DateTime now' . + 'FileDirectory pathNameDelimiter' -> 'Directory pathSeparator' . + 'FileDirectory default' -> 'Directory working' . + '(FileDirectory deleteFilePath: ``@arg2)' -> '(File remove: ``@arg2)' . + '(FileDirectory localNameFor: ``@arg2)' -> '(FilePath stripPathFrom: ``@arg2)' . + '(``@object recursiveDelete)' -> '(``@object all remove)' . + '(``@object pathName)' -> '(``@object name)' . + '(``@object containingDirectory)' -> '(``@object parent)' . + '(``@object assureExistence)' -> '(``@object createDirectories)' . + '(``@object fileExists: ``@arg2)' -> '(``@object / ``@arg2) exists' . + '(FileDirectory on: ``@arg2)' -> '(``@arg2 asFile)' . + '(``@object directoryNamed: ``@arg2)' -> '(``@object / ``@arg2)' . + '(``@object readOnlyFileNamed: ``@arg2)' -> '(``@object / ``@arg2) readStream' . + '(``@object forceNewFileNamed: ``@arg2)' -> '(``@object / ``@arg2) writeStream' . + '(``@object allSubInstancesDo: ``@arg2)' -> '(``@object allSubinstancesDo: ``@arg2)' . + '(``@object newFrom: ``@arg2)' -> '(``@object from: ``@arg2)' . + '((``@object methodClass organization categoryOfElement: ``@object selector))' -> '(``@object methodCategory)' + }! ! + +!GCGstConvertCommand class methodsFor: 'bidirectional-rules' stamp: 'tfel 9/13/2009 13:04'! +statements + + ^ { '(``@object ifNil: ``@arg ifNotNil: [ | `@t2 | `@.s2 ])' -> '(``@object ifNil: ``@arg ifNotNil: [ :foo || `@t2 | `@.s2 ])' . + '(``@object ifNotNil: [ | `@t2 | `@.s2 ] ifNil: ``@arg)' -> '(``@object ifNotNil: [ :foo || `@t2 | `@.s2 ] ifNil: ``@arg)' . + '(``@object ifNotNil: [ | `@t2 | `@.s2 ])' -> '(``@object ifNotNil: [ :foo || `@t2 | `@.s2 ])' . + }! ! + + +!GCGstConvertCommand class methodsFor: 'actions' stamp: 'tfel 6/14/2010 17:32'! +convert: aFilepath from: input to: output + + self runGstConvert ifTrue: [ + self basicConvert: aFilepath from: input to: output].! ! + + +!GCGstConvertCommand class methodsFor: 'gst-to-squeak-rules' stamp: 'tfel 9/14/2009 00:52'! +gstBidirectional + "Reverse all bidirectional rules to apply them for squeak -> gst conversion" + ^ (self allMethodsIn: 'bidirectional-rules') + inject: OrderedCollection new + into: [:list :method | + list union: ((self perform: method) + collect: [:each | each value -> each key])]! ! + + +!GCGstConvertCommand class methodsFor: 'preferences' stamp: 'tfel 6/14/2010 15:45'! +gstConvertBinaryPath + - ^GstConvertBinaryPath ifNil: [GstConvertBinaryPath := 'gst-convert'] - ] + ^ GstConvertBinaryPath ifNil: [GstConvertBinaryPath := 'gst-convert'] +! ! + +!GCGstConvertCommand class methodsFor: 'preferences' stamp: 'tfel 6/14/2010 15:49'! +gstConvertBinaryPath: aString - GCGstConvertCommand class >> gstConvertBinaryPath: aString [ - - GstConvertBinaryPath := aString - ] + GstConvertBinaryPath := aString. +! ! + +!GCGstConvertCommand class methodsFor: 'preferences' stamp: 'tfel 6/14/2010 15:47'! +runGstConvert - GCGstConvertCommand class >> runGstConvert [ - - ^RunGstConvert ifNil: [RunGstConvert := false] - ] + ^ RunGstConvert ifNil: [RunGstConvert := false] +! ! + +!GCGstConvertCommand class methodsFor: 'preferences' stamp: 'tfel 6/14/2010 15:47'! +runGstConvert: aBoolean + + RunGstConvert := aBoolean. +! ! - GCGstConvertCommand class >> runGstConvert: aBoolean [ - - RunGstConvert := aBoolean - ] -] +!GCGstConvertCommand class methodsFor: 'literals' stamp: 'tfel 9/13/2009 11:42'! +gstNewline + + ^ '\\n'! ! + +!GCGstConvertCommand class methodsFor: 'literals' stamp: 'tfel 9/13/2009 11:42'! +squeakNewline + + ^ '\\r'! ! + + +!GCGstConvertCommand class methodsFor: 'squeak-to-gst-rules' stamp: 'tfel 9/14/2009 00:52'! +squeakBidirectional + "Find all bidirectional rules to include them in the conversion" + ^ (self allMethodsIn: 'bidirectional-rules') + inject: OrderedCollection new + into: [:list :method | list union: (self perform: method)]! ! + +!GCGstConvertCommand class methodsFor: 'squeak-to-gst-rules' stamp: 'tfel 9/13/2009 10:36'! +squeakClassNames + + ^ { 'TimeStamp' -> 'DateTime' . + 'ProtoObject' -> 'nil' . + }! ! + +!GCGstConvertCommand class methodsFor: 'squeak-to-gst-rules' stamp: 'tfel 9/14/2009 01:24'! +squeakMethodNames + + ^ { '(``@object caseInsensitiveLessOrEqual: ``@arg2)' -> '(``@object <= ``@arg2)' . + '(``@object isZero)' -> '(``@object = 0)' . + 'FileDirectory dot' -> '($. printString)' . + '(``@object directoryExists: ``@arg2)' -> '(File path: ``@arg2) exists' . + '(``@object union: ``@arg1)' -> '(``@object asSet addAll: ``@arg1; yourself)' . + 'FileStream st' -> '($s printString, $t printString)' . + '(``@object beginsWith: ``@arg2)' -> '(``@object startsWith: ``@arg2)' . + '(``@object ifNil: ``@arg1 ifNotNilDo: ``@arg2)' -> '(``@object ifNil: ``@arg1 ifNotNil: ``@arg2)' . + '(``@object ifNotNilDo: ``@arg2 ifNil: ``@arg1)' -> '(``@object ifNotNil: ``@arg2 ifNil: ``@arg1)' . + '(``@object ifNotNilDo: ``@arg2)' -> '(``@object ifNotNil: ``@arg2)' . + '(``@object doIfNotNil: ``@arg2)' -> '(``@object ifNotNil: ``@arg2)' . + }! ! + +!GCGstConvertCommand class methodsFor: 'squeak-to-gst-rules' stamp: 'tfel 9/13/2009 13:13'! +squeakStatements + + ^ { '(``@object and: ``@arg1 and: ``@arg2)' -> '((``@object and: ``@arg1) and: ``@arg2)' . + }! ! + + +!GCGstConvertCommand class methodsFor: 'command-building' stamp: 'tfel 9/13/2009 19:59'! +writeRules: someRules to: aStream + + someRules do: [:each | + aStream + nextPutAll: '-r'; + nextPut: $'; + nextPutAll: (each printString copyWithout: $'); + nextPut: $'; + nextPut: Character space]! ! diff --git a/GST/GCGstPackageWriter.st b/GST/GCGstPackageWriter.st index 7da2ffe..5acb4ac 100644 --- a/GST/GCGstPackageWriter.st +++ b/GST/GCGstPackageWriter.st @@ -1,241 +1,221 @@ -Object subclass: GCGstPackageWriter [ - | package packageXmlStream newline repoDir | - - - +I will at some stage be able to properly handle test cases, which will make porting so much easier.! - WritePackageXml := nil. - GCGstPackageWriter class >> writePackageXml [ - - - ^WritePackageXml ifNil: [WritePackageXml := false] - ] +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 4/25/2010 17:13:51.474'! +classFilePathFor: aClass + "Find the path to the classes fileOut" + | subfolder | + subfolder := (aClass theNonMetaClass category asString findBetweenSubStrs: '-') last. + ^ subfolder, FileDirectory pathNameDelimiter asString, + aClass name asString, FileDirectory dot, FileStream st! ! - GCGstPackageWriter class >> writePackageXml: aBoolean [ - - WritePackageXml := aBoolean - ] +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/20/2009 13:07'! +classes - GCGstPackageWriter class >> newFor: aPackage [ - - ^(self new) - package: aPackage; - yourself - ] + ^ (GCRegistry at: self packageName) packageClasses! ! - classFilePathFor: aClass [ - "Find the path to the classes fileOut" +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/10/2009 14:14'! +createPackageXml - - | subfolder | - subfolder := (PackageInfo - named: (aClass theNonMetaClass category asString findBetweenSubStrs: '-') - first) - name = self packageName - ifTrue: - [(aClass theNonMetaClass category asString findBetweenSubStrs: '-') last] - ifFalse: [GCMapper extensionsFolder]. - ^subfolder , Directory pathSeparator asString , aClass name asString - , $. printString , ($s printString , $t printString) - ] - - classes [ - - ^(GCRegistry at: self packageName) packageClasses - ] - - createPackageXml [ - self packageXmlStream reset. - self - preamble; - requires; - tests; - fileIns; - files. - self packageXmlStream nextPutAll: self postfix - ] - - fileIn: aClass [ - - self putAttribute: 'filein' with: (self classFilePathFor: aClass) - ] - - fileIns [ - - self classes reject: [:class | class allSuperclasses includes: TestCase] - thenDo: [:class | self fileIn: class] - ] - - files [ - - self packageClasses - do: [:class | self putAttribute: 'file' with: (self classFilePathFor: class)] - ] - - preamble [ - - - {''. - ''. - ''} + self + preamble; + requires; + tests; + fileIns; + files. + self packageXmlStream nextPutAll: self postfix! ! + +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/10/2009 14:17'! +fileIn: aClass + + self putAttribute: 'filein' with: (self classFilePathFor: aClass)! ! + +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/10/2009 14:17'! +fileIns + + self classes + reject: [:class | class allSuperclasses includes: TestCase] + thenDo: [:class | self fileIn: class]! ! + +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/10/2009 14:15'! +files + + self classes do: [:class | + self + putAttribute: 'file' + with: (self classFilePathFor: class) + ]! ! + +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/10/2009 14:32'! +preamble + + {'' . ''. ''} do: [:s | self packageXmlStream nextPutAll: s] separatedBy: [self packageXmlStream nextPut: newline]. - self - putAttribute: 'name' with: self packageName; - putAttribute: 'namespace' with: self packageName - ] - - putAttribute: anXmlAttribute with: someContent [ - - (self packageXmlStream) - nextPutAll: '<' , anXmlAttribute , '>'; - nextPutAll: someContent; - nextPutAll: ''; - nextPut: newline - ] - - require: aPackage [ - - (self packageXmlStream) - nextPutAll: ''; - nextPutAll: aPackage; - nextPutAll: ''; - nextPut: newline - ] - - requires [ - - self requiredPackages do: [:pkg | self require: pkg] - ] - - tests [ - "Prepare the tests for usage with Gnu Smalltalk" + self + putAttribute: 'name' with: self packageName; + putAttribute: 'namespace' with: self packageName.! ! + +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/10/2009 13:58'! +putAttribute: anXmlAttribute with: someContent + + self packageXmlStream + nextPutAll: '<', anXmlAttribute, '>'; + nextPutAll: someContent; + nextPutAll: ''; + nextPut: newline + ! ! - +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/7/2009 20:58'! +require: aPackage + + self packageXmlStream + nextPutAll: ''; + nextPutAll: aPackage; + nextPutAll: ''; + nextPut: newline! ! + +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/10/2009 13:44'! +requires + + self requiredPackages do: [:pkg | self require: pkg]! ! + +!GCGstPackageWriter methodsFor: 'stream-writing' stamp: 'tfel 9/14/2009 00:58'! +tests + "Prepare the tests for usage with Gnu Smalltalk" | testClasses testCases | - testClasses := self classes - select: [:class | class allSuperclasses includes: TestCase]. - testCases := testClasses inject: String new - into: [:s :class | s , self packageName , '.' , class name asString , newline asString]. - self packageXmlStream nextPutAll: '' , newline asString. + testClasses := self classes select: [:class | class allSuperclasses includes: TestCase]. + testCases := testClasses inject: String new into: [:s :class | + s, self packageName, '.', class name asString, newline asString]. + self packageXmlStream nextPutAll: '', newline asString. testClasses do: [:class | self fileIn: class]. self putAttribute: 'sunit' with: testCases. - self packageXmlStream nextPutAll: '' , newline asString - ] + self packageXmlStream nextPutAll: '', newline asString.! ! + + +!GCGstPackageWriter methodsFor: 'fileOut' stamp: 'tfel 6/14/2010 16:05'! +fileOutPackageXml - fileOutPackageXml [ - | fileName converter file | - self class writePackageXml - ifTrue: - [self createPackageXml. + self class writePackageXml ifTrue: [ + self createPackageXml. self packageXmlStream contents isAsciiString - ifTrue: [converter := MacRomanTextConverter new] - ifFalse: [converter := UTF8TextConverter new]. - fileName := self repoDir , Directory pathSeparator asString - , 'package.xml'. - File remove: fileName. + ifTrue: [converter := MacRomanTextConverter new] + ifFalse: [converter := UTF8TextConverter new]. + fileName := self repoDir, FileDirectory pathNameDelimiter asString, 'package.xml'. + FileDirectory deleteFilePath: fileName. file := MultiByteFileStream new open: fileName forWrite: true. - file ifNil: [self error: 'Cannot open file']. - file - text; - converter: converter; - nextPutAll: packageXmlStream contents; - close] - ] - - initialize [ - + file ifNil: [self error: 'Cannot open file']. + file text; + converter: converter; + nextPutAll: packageXmlStream contents; + close].! ! + + +!GCGstPackageWriter methodsFor: 'initialize-release' stamp: 'tfel 9/7/2009 21:32'! +initialize + super initialize. - newline := Character lf. "This should be configurable" - self packageXmlStream: (WriteStream on: (String new: 100)) - ] + newline := Character lf. "This should be configurable" + self packageXmlStream: (WriteStream on: (String new: 100))! ! - newline [ + +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 21:25'! +newline "Answer the value of newline" - - ^newline - ] + ^ newline! ! - newline: anObject [ +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 21:25'! +newline: anObject "Set the value of newline" - - newline := anObject - ] + newline := anObject! ! - package [ +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 20:47'! +packageName "Answer the value of packageName" - - ^package - ] + ^ packageName! ! - package: anObject [ +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 20:47'! +packageName: anObject "Set the value of packageName" - - package := anObject - ] - - packageClasses [ - "Answer the value of packageName" + packageName := anObject! ! - - ^package packageClasses - ] - - packageName [ - - ^self package packageName - ] - - packageXmlStream [ +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 20:47'! +packageXmlStream "Answer the value of packageXmlStream" - - ^packageXmlStream - ] + ^ packageXmlStream! ! - packageXmlStream: anObject [ +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 20:47'! +packageXmlStream: anObject "Set the value of packageXmlStream" - - packageXmlStream := anObject - ] + packageXmlStream := anObject! ! - repoDir [ +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 21:25'! +repoDir "Answer the value of repoDir" - - ^repoDir - ] + ^ repoDir! ! - repoDir: aDirectory [ +!GCGstPackageWriter methodsFor: 'accessing' stamp: 'tfel 9/7/2009 21:28'! +repoDir: aDirectory "Set the value of repoDir" - - aDirectory isString - ifTrue: [repoDir := aDirectory] - ifFalse: [repoDir := aDirectory name] - ] + aDirectory isString + ifTrue: [repoDir := aDirectory] + ifFalse: [repoDir := aDirectory pathName]! ! + + +!GCGstPackageWriter methodsFor: 'literals' stamp: 'tfel 6/14/2010 15:52'! +postfix + + ^ '', Character cr asString! ! + - postfix [ - - ^'' , Character cr asString - ] +!GCGstPackageWriter methodsFor: 'information-retrieval' stamp: 'tfel 9/7/2009 20:36'! +requiredPackages - requiredPackages [ - - ^(MCPackage named: self packageName) workingCopy requiredPackages - ] -] + ^ (MCPackage named: self packageName) workingCopy requiredPackages! ! +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! + +GCGstPackageWriter class + instanceVariableNames: ''! + +!GCGstPackageWriter class methodsFor: 'instance creation' stamp: 'tfel 4/25/2010 16:52:37.173'! +newFor: aPackage + + ^ self new + packageName: aPackage; + yourself! ! + + +!GCGstPackageWriter class methodsFor: 'preferences' stamp: 'tfel 6/14/2010 15:42'! +writePackageXml + + + ^ WritePackageXml ifNil: [WritePackageXml := false] +! ! + +!GCGstPackageWriter class methodsFor: 'preferences' stamp: 'tfel 6/14/2010 15:42'! +writePackageXml: aBoolean + + WritePackageXml := aBoolean +! ! diff --git a/Morphic/GCRepositoryBrowser.st b/Morphic/GCRepositoryBrowser.st index 7dc2d65..750d5a9 100644 --- a/Morphic/GCRepositoryBrowser.st +++ b/Morphic/GCRepositoryBrowser.st @@ -1,205 +1,184 @@ -SystemWindow subclass: GCRepositoryBrowser [ - | repositoryIndex selectedClassIndex classList selectedClasses classListMorph packageListMorph | - - - - - GCRepositoryBrowser class >> open [ - - (self new) - createWindow; - openInWorld - ] - - classListMorph [ - - ^classListMorph ifNil: - [classListMorph := (PluggableListMorphOfMany - on: self - list: #availableClasses - primarySelection: #selectedClassIndex - changePrimarySelection: #selectedClassIndex: - listSelection: #selectedClassesAt: - changeListSelection: #selectedClassesAt:put: - menu: nil) - color: self defaultBackgroundColor; - yourself] - ] - - createWindow [ - - self - addMorph: self repositoryUrlField frame: (0 @ 0.01 corner: 0.8 @ 0.1); - addMorph: self syncButton frame: (0.8 @ 0.01 corner: 1.0 @ 0.1); - addMorph: self packageListMorph frame: (0 @ 0.1 corner: 0.5 @ 1.0); - addMorph: self classListMorph frame: (0.5 @ 0.1 corner: 1.0 @ 1.0); - setLabel: 'Package Git Repository Mirrors' - ] - - packageListMorph [ - - ^packageListMorph ifNil: - [packageListMorph := (PluggableListMorph - on: self - list: #repositoryList - selected: #selectedRepositoryIndex - changeSelected: #selectedRepositoryIndex:) - color: self defaultBackgroundColor; - yourself] - ] - - repositoryUrlField [ - - ^(PluggableTextMorph - on: self - text: #repositoryRootPath - accept: #repositoryRootPath:) - hideScrollBarsIndefinitely; - color: self defaultBackgroundColor; - yourself - ] - - syncButton [ - - ^PluggableButtonMorph - on: self - getState: #syncButtonOn - action: #syncButtonAction - label: #syncButtonString - ] - - repositoryList [ - - ^GCRegistry repositories keys asOrderedCollection - ] - - selectedRepository [ - - ^self repositoryList at: self selectedRepositoryIndex - ] - - selectedRepositoryIndex [ +SystemWindow subclass: #GCRepositoryBrowser + instanceVariableNames: 'repositoryIndex selectedClassIndex classList selectedClasses' + classVariableNames: '' + poolDictionaries: '' + category: 'Gitocello-Morphic'! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 4/26/2010 22:23'! +classList + + + classList ifNil: [ + classList := GCRegistry repositories + ifEmpty: [#()] + ifNotEmpty: [(GCRegistry at: self selectedRepository) classes]]. + ^ classList! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 9/20/2009 15:04'! +classListMap + + ^ self classList + collect: [:class | self packageClasses includes: class]! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 9/20/2009 14:08'! +contents + + ^ self selectedRepository! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 6/14/2010 16:03'! +createWindow + + | packageList classList repositoryUrlEntry fileOutCommand | + (fileOutCommand := PluggableButtonMorph + on: self + getState: nil + action: #fileOut + label: #fileOutButtonString). + repositoryUrlEntry := (PluggableTextMorph on: self + text: #repositoryRoot + accept: #repositoryRoot: + readSelection: nil + menu: #annotationPaneMenu:shifted:) + hideScrollBarsIndefinitely; + yourself. + (packageList := PluggableListMorph new) + on: self list: #repositoryList + selected: #repositoryIndex changeSelected: #repositoryIndex: + menu: #memberMenu:shifted: keystroke: nil. + (classList := PluggableListMorphOfMany new) + on: self list: #classList + primarySelection: #selectedClassIndex changePrimarySelection: #selectedClassIndex: + listSelection: #selectedClassesAt: changeListSelection: #selectedClassesAt:put: + menu: #classMenu keystroke: nil. + repositoryUrlEntry color: self defaultBackgroundColor. + classList color: self defaultBackgroundColor. + packageList color: self defaultBackgroundColor. + self addMorph: repositoryUrlEntry frame: (0@0.01 corner: 0.8@0.1). + self addMorph: fileOutCommand frame: (0.8@0.01 corner: 1.0@0.1). + self addMorph: packageList frame: (0@0.1 corner: 0.5@1.0). + self addMorph: classList frame: (0.5@0.1 corner: 1.0@1.0). + + self setLabel: 'Package Git Repository Mirrors'! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 6/14/2010 16:08'! +fileOut + + GCRegistry createFilesFor: self selectedRepository.! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 4/26/2010 22:21'! +initialize + + super initialize. + self + repositoryIndex: 1; + selectedClassIndex: 1; + selectedClasses: self classListMap! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 9/20/2009 14:03'! +repositoryList + + ^ GCRegistry repositories keys asOrderedCollection! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 9/20/2009 14:58'! +selectedClassesAt: anIndex + + ^ selectedClasses at: anIndex! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 9/20/2009 15:16'! +selectedClassesAt: anIndex put: aValue + + selectedClasses at: anIndex put: (aValue = true). + self + changed: #selectedClassIndex; + updatePackageClasses! ! + +!GCRepositoryBrowser methodsFor: 'as yet unclassified' stamp: 'tfel 9/20/2009 14:10'! +selectedRepository + + ^ self repositoryList at: self repositoryIndex! ! + + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 15:02'! +classList: anObject + "Set the value of classList" + + classList := anObject! ! + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 6/14/2010 15:58'! +fileOutButtonString + + ^ 'Sync repository'! ! + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 4/26/2010 22:22'! +packageClasses + + ^ GCRegistry repositories + ifEmpty: [#()] + ifNotEmpty: [(GCRegistry at: self selectedRepository) packageClasses].! ! + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:01'! +repositoryIndex "Answer the value of repositoryIndex" - - ^repositoryIndex - ] + ^ repositoryIndex! ! - selectedRepositoryIndex: anObject [ +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:45'! +repositoryIndex: anObject "Set the value of repositoryIndex" - repositoryIndex := anObject. - classList := nil. - self - selectedClassIndex: 1; - selectedClasses: self currentlySelectedClasses; - changed: #selectedRepositoryIndex; - changed: #selectedClassesAt:; - changed: #availableClasses - ] - - updatePackageClasses [ - - (GCRegistry at: self selectedRepository) - packageClasses: (self availableClasses - select: [:class | self selectedClasses at: (self availableClasses indexOf: class)]) - ] - - repositoryRootPath [ - - ^GCRegistry repositoryRoot name - ] - - repositoryRootPath: aString [ - - ^GCRegistry repositoryRoot: aString - ] - - syncButtonAction [ - - GCRegistry createFilesFor: self selectedRepository - ] - - syncButtonOn [ - - ^GCRegistry repositories isEmpty not - ] - - syncButtonString [ - - ^'Sync repository' - ] - - availableClasses [ - - classList ifNil: - [classList := GCRegistry repositories ifEmpty: [#()] - ifNotEmpty: [(GCRegistry at: self selectedRepository) classes]]. - ^classList - ] - - currentlySelectedClasses [ - - ^self availableClasses collect: [:cls | self packageClasses includes: cls] - ] - - packageClasses [ - - ^GCRegistry repositories ifEmpty: [#()] - ifNotEmpty: [(GCRegistry at: self selectedRepository) packageClasses] - ] - - selectedClassIndex [ + classList := nil! ! + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 10/2/2009 21:35'! +repositoryRoot + + ^ GCRegistry repositoryRoot pathName! ! + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 10/2/2009 21:34'! +repositoryRoot: aString + + ^ GCRegistry repositoryRoot: aString! ! + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:51'! +selectedClassIndex "Answer the value of selectedClassIndex" - - ^selectedClassIndex - ] + ^ selectedClassIndex! ! - selectedClassIndex: anObject [ +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 14:51'! +selectedClassIndex: anObject "Set the value of selectedClassIndex" - - selectedClassIndex := anObject. - self changed: #selectedClassIndex - ] + selectedClassIndex := anObject! ! - selectedClasses [ +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 15:02'! +selectedClasses "Answer the value of selectedClasses" - - ^selectedClasses - ] + ^ selectedClasses! ! - selectedClasses: anObject [ +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 15:02'! +selectedClasses: anObject "Set the value of selectedClasses" - - selectedClasses := anObject - ] - - selectedClassesAt: anIndex [ - - ^selectedClasses at: anIndex - ] - - selectedClassesAt: anIndex put: aValue [ - - selectedClasses at: anIndex put: aValue = true. - self - changed: #selectedClassIndex; - changed: #availableClasses; - updatePackageClasses - ] - - initialize [ - - self - selectedRepositoryIndex: 1; - selectedClassIndex: 1; - selectedClasses: self currentlySelectedClasses. - super initialize - ] -] + selectedClasses := anObject! ! + +!GCRepositoryBrowser methodsFor: 'accessing' stamp: 'tfel 9/20/2009 15:15'! +updatePackageClasses + + (GCRegistry at: self selectedRepository) + packageClasses: (self classList + select: [:class | + self selectedClasses at: (self classList indexOf: class)])! ! + +"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! + +GCRepositoryBrowser class + instanceVariableNames: ''! + +!GCRepositoryBrowser class methodsFor: 'as yet unclassified' stamp: 'tfel 9/20/2009 15:18'! +open + (self new) + createWindow; + openInWorld! !