Squeak-dev June 2015

squeak-dev@lists.squeakfoundation.org

35 participants
162 discussions

Squeak 4.6: SystemReporter-mt.24.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SystemReporter to project Squeak 4.6: http://source.squeak.org/squeak46/SystemReporter-mt.24.mcz ==================== Summary ==================== Name: SystemReporter-mt.24 Author: mt Time: 18 May 2015, 10:16:53.323 am UUID: 8a99a2df-13ea-6149-bcad-cb460f6c8e6b Ancestors: SystemReporter-dtl.23 Fixed confirm-actions for all longer lasting operations in the system reporter: space analysis, tiny benchmarks, test runner. Support 'cancel' for all of them. ==================== Snapshot ==================== SystemOrganization addCategory: #SystemReporter! Object subclass: #SystemReporter instanceVariableNames: 'categories categoriesSelected report tinyBenchmarksResult categoryList testRunner spaceAnalysisResult' classVariableNames: '' poolDictionaries: '' category: 'SystemReporter'! !SystemReporter commentStamp: 'laza 1/18/2011 12:04' prior: 0! SystemReporter offers a window where information about the system is gathered. This can be easily copied to the clipboard and be attached to a bug report for better identification of the context the bug occured in. To extend the SystemReporter: - add a method reportXYZ: aStream to the reporting category - insert a line add: #XYZ method: #reportXYZ to the initialize method ! ----- Method: SystemReporter class>>open (in category 'instance creation') ----- open ^ ToolBuilder open: self new.! ----- Method: SystemReporter>>add:method: (in category 'accessing-categories') ----- add: category method: aSymbol ^self categoryList add: (self categories add: category -> aSymbol) key! ----- Method: SystemReporter>>buildCategoriesWith: (in category 'building') ----- buildCategoriesWith: aBuilder ^ aBuilder pluggableMultiSelectionListSpec new model: self; list: #categoryList; menu: #categoryMenu:; getIndex: #categorySelected; setIndex: #categorySelected:; getSelectionList: #categoryAt:; setSelectionList: #categoryAt:put:; yourself.! ----- Method: SystemReporter>>buildReportWith: (in category 'building') ----- buildReportWith: aBuilder ^ aBuilder pluggableTextSpec new model: self; menu: #reportMenu:; getText: #reportText; yourself.! ----- Method: SystemReporter>>buildWith: (in category 'building') ----- buildWith: aBuilder | window | window := aBuilder pluggableWindowSpec new model: self; label: self label; extent: self extent; children: (OrderedCollection new add: ((self buildCategoriesWith: aBuilder) frame: self categoriesFrame; yourself); add: ((self buildReportWith: aBuilder) frame: self reportFrame; yourself); yourself); yourself. ^ aBuilder build: window.! ----- Method: SystemReporter>>categories (in category 'accessing-categories') ----- categories ^ categories ifNil: [categories := IdentityDictionary new]! ----- Method: SystemReporter>>categoriesFrame (in category 'building') ----- categoriesFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: 0; rightFraction: 0.25 offset: 0; bottomFraction: 1 offset: 0! ----- Method: SystemReporter>>categoryAt: (in category 'accessing-categories') ----- categoryAt: anIndex ^ categoriesSelected includes: (self categoryList at: anIndex ifAbsent: [ ^ false ]).! ----- Method: SystemReporter>>categoryAt:put: (in category 'accessing-categories') ----- categoryAt: anInteger put: aBoolean categoriesSelected := categoriesSelected perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) with: (self categoryList at: anInteger ifAbsent: [ ^ self ]). self updateReport! ----- Method: SystemReporter>>categoryList (in category 'accessing-categories') ----- categoryList ^ categoryList ifNil: [categoryList := OrderedCollection new]! ----- Method: SystemReporter>>categoryMenu: (in category 'accessing-categories') ----- categoryMenu: aMenu ^ aMenu title: 'Categories'; add: 'Select all' action: #selectAllCategories; add: 'Select none' action: #selectNoCategories; addLine; add: 'Refresh' action: #refresh; yourself.! ----- Method: SystemReporter>>categorySelected (in category 'accessing-categories') ----- categorySelected ^ 0! ----- Method: SystemReporter>>categorySelected: (in category 'accessing-categories') ----- categorySelected: anInteger self changed: #categorySelected.! ----- Method: SystemReporter>>copyReportToClipboard (in category 'accessing-report') ----- copyReportToClipboard Clipboard clipboardText: self reportText. UIManager default inform: 'Copied Report to Clipboard'! ----- Method: SystemReporter>>enumerate:on: (in category 'private') ----- enumerate: aBlock on: aStream self enumerate: aBlock startAt: 0 on: aStream! ----- Method: SystemReporter>>enumerate:startAt:on: (in category 'private') ----- enumerate: aBlock startAt: first on: aStream "Utilitymethod to enumerate Options or Parameters from first to 1000" | idx value | idx := first. [value := aBlock value: idx. value = nil or: [idx > 1000]] whileFalse: [ aStream nextPut: $#; nextPutAll: idx printString; tab; nextPutAll: value; cr. idx := idx + 1 ]. idx = first ifTrue: [aStream nextPutAll: 'none'; cr]! ----- Method: SystemReporter>>extent (in category 'accessing-ui') ----- extent ^ 640 @ 480! ----- Method: SystemReporter>>header:on: (in category 'printing-report') ----- header: aString on: aStream aStream withAttribute: TextEmphasis bold do: [ aStream nextPutAll: aString; cr. aString size timesRepeat: [aStream nextPut: $-]. aStream cr]! ----- Method: SystemReporter>>initialize (in category 'initialize-release') ----- initialize self add: #Image method: #reportImage; add: #'Image Parameters' method: #reportImageParameters; add: #'Image Sources' method: #reportSources; add: #'Image Preferences' method: #reportPreferences; add: #'MC Repositories' method: #reportRepositories; add: #'MC Working Copies' method: #reportWorkingCopies; add: #'VM General' method: #reportVM; add: #'VM Options' method: #reportVMOptions; add: #'VM Modules' method: #reportModules; add: #'VM Parameters' method: #reportVMParameters; add: #'VM Stats' method: #reportVMStats. Smalltalk os platformName = 'Win32' ifTrue: [ self add: #'VM Configuration' method: #reportWin32VMConfig. ]. self add: #'OS General' method: #reportOS. Smalltalk os platformName = 'Win32' ifTrue: [ self add: #'OS Details' method: #reportWin32OSDetails; add: #'Hardware Details' method: #reportWin32HardwareDetails; add: #'GFX Hardware Details' method: #reportWin32GFXDetails. ]. Smalltalk os osVersion = 'linux' ifTrue: [ self add: #'OS Details' method: #reportLinuxOSDetails ]. self add: #'Tiny Benchmarks' method: #reportTinyBenchmarks; add: #'Space Analysis' method: #reportSpaceAnalysis; add: #'SUnit' method: #reportTestRunner; add: #'Debug Log' method: #reportDebugLog. categoriesSelected := Set with: #Image with: #'VM General'. self updateReport ! ----- Method: SystemReporter>>label (in category 'accessing-ui') ----- label ^ 'System Reporter' ! ----- Method: SystemReporter>>printDebugExpressionFor:on: (in category 'private') ----- printDebugExpressionFor: methodSignature on: aStream | compiledMethod | compiledMethod := Compiler evaluate: methodSignature. aStream nextPut: $( ; nextPutAll: compiledMethod methodClass name ; nextPutAll: ' selector: #' ; nextPutAll: compiledMethod selector ; nextPutAll: ') debug.'! ----- Method: SystemReporter>>refresh (in category 'accessing-categories') ----- refresh spaceAnalysisResult := tinyBenchmarksResult := testRunner := nil. self updateReport! ----- Method: SystemReporter>>reportDebugLog: (in category 'reporting') ----- reportDebugLog: aStream | logFilename logStream contents | self header: 'Debug Logfile' on: aStream. logFilename := Smalltalk image squeakErrorFileName. logStream := nil. [ [ logStream := FileStream readOnlyFileNamed: logFilename. aStream nextPutAll: logStream name; cr; cr. contents := logStream contents. aStream nextPutAll: ((contents isNil or: [contents size = 0]) ifTrue: ['<empty>'] ifFalse: [contents]); cr ] on: Error do: [:ex | aStream nextPutAll: ( ex class = FileDoesNotExistException ifTrue: [logFilename, ' not found'] ifFalse: [ex description]); cr ] ] ensure: [ logStream ifNotNil: [logStream close] ]! ----- Method: SystemReporter>>reportFrame (in category 'building') ----- reportFrame ^LayoutFrame new leftFraction: 0.25 offset: 0; topFraction: 0 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 1 offset: 0! ----- Method: SystemReporter>>reportImage: (in category 'reporting') ----- reportImage: aStream self header: 'Image' on: aStream. aStream nextPutAll: Smalltalk image imageName; cr; nextPutAll: SystemVersion current version; cr; nextPutAll: Smalltalk image lastUpdateString; cr; nextPutAll: Smalltalk image currentChangeSetString; cr. [ | imageFormat bitsPerWord | imageFormat := Smalltalk image imageFormatVersion. bitsPerWord := Smalltalk image wordSize * 8. aStream nextPutAll: 'Image format '; nextPutAll: imageFormat asString; nextPutAll: ' ('; nextPutAll: bitsPerWord asString; nextPutAll: ' bit)'; cr] on: Warning do: ["primitive not present in VM"]. ! ----- Method: SystemReporter>>reportImageParameters: (in category 'reporting') ----- reportImageParameters: aStream self header: 'Image Commandline Parameters' on: aStream. self enumerate: [:idx | Smalltalk image argumentAt: idx] on: aStream.! ----- Method: SystemReporter>>reportLinuxOSDetails: (in category 'reporting') ----- reportLinuxOSDetails: aStream self header: 'Operating System Details' on: aStream. #( '/etc/issue' '/etc/lsb-release' '/proc/version' ) do: [:path| self writeContentsSafelyFromFile: path on: aStream]! ----- Method: SystemReporter>>reportMenu: (in category 'accessing-report') ----- reportMenu: aMenu ^ aMenu title: 'Report'; add: 'Copy to Clipboard' action: #copyReportToClipboard; yourself.! ----- Method: SystemReporter>>reportModules: (in category 'reporting') ----- reportModules: aStream self header: 'Loaded VM Modules' on: aStream. SmalltalkImage current listLoadedModules asSortedCollection do: [:each | aStream nextPutAll: each; cr]. ! ----- Method: SystemReporter>>reportOS: (in category 'reporting') ----- reportOS: aStream self header: 'Operating System/Hardware' on: aStream. aStream nextPutAll: Smalltalk os platformName; space; nextPutAll: Smalltalk os osVersion; space; nextPutAll: Smalltalk os platformSubtype; cr ! ----- Method: SystemReporter>>reportPreferences: (in category 'reporting') ----- reportPreferences: aStream | booleanPrefs prefs valuePrefs attribute falseTA trueTA | prefs := Preferences dictionaryOfPreferences. booleanPrefs := prefs select: [:each | each type = #Boolean]. valuePrefs := prefs select: [:each | each type = #Number or: [each type = #String]]. trueTA := TextColor black. falseTA := TextColor gray. booleanPrefs := booleanPrefs asSortedCollection: [:a :b | a name <= b name]. self header: 'Boolean Preferences' on: aStream. booleanPrefs do: [:each | attribute := each preferenceValue ifTrue: [trueTA] ifFalse: [falseTA]. aStream withAttribute: attribute do: [ aStream nextPutAll: each name; tab; nextPutAll: each preferenceValue printString; cr]]. aStream cr. self header: 'Value Preferences' on: aStream. valuePrefs do: [:each | aStream nextPutAll: each name; tab; nextPutAll: each preferenceValue printString; cr]. ! ----- Method: SystemReporter>>reportRepositories: (in category 'reporting') ----- reportRepositories: aStream self header: 'Monticello Repositories' on: aStream. MCRepositoryGroup default repositories do: [:each | aStream nextPutAll: each description; cr]! ----- Method: SystemReporter>>reportSources: (in category 'reporting') ----- reportSources: aStream self header: 'Image Sources' on: aStream. aStream nextPutAll: SourceFiles class printString; cr. SourceFiles do: [:each | each ifNotNil: [aStream nextPutAll: each printString; cr]]! ----- Method: SystemReporter>>reportSpaceAnalysis: (in category 'reporting') ----- reportSpaceAnalysis: aStream spaceAnalysisResult ifNil: [ (UIManager default confirm: 'Running the space analysis\might take a few seconds.' withCRs translated title: 'Continue?' translated) ifFalse: [ categoriesSelected remove: #'Space Analysis'. ^ self changed: #categorySelected ]. spaceAnalysisResult := String streamContents: [ :stream | SpaceTally new printSpaceAnalysis: 1 onStream: stream ] ]. self header: 'Space Analysis' on: aStream. aStream nextPutAll: spaceAnalysisResult; cr! ----- Method: SystemReporter>>reportTestRunner: (in category 'reporting') ----- reportTestRunner: aStream testRunner ifNil: [ (UIManager default confirm: 'Running all tests might\take a some minutes.' withCRs translated title: 'Continue?') ifTrue: [ testRunner := TestRunner new runAll ] ifFalse: [ categoriesSelected remove: #SUnit. ^ self changed: #categorySelected ] ]. self header: 'SUnit Results' on: aStream. aStream nextPutAll: testRunner statusText ; cr ; cr. self header: 'Failed Tests' on: aStream. testRunner failedList do: [ : each | self printDebugExpressionFor: each on: aStream. aStream cr ]. aStream cr. self header: 'Errors' on: aStream. testRunner errorList do: [ : each | self printDebugExpressionFor: each on: aStream. aStream cr ]! ----- Method: SystemReporter>>reportText (in category 'accessing-report') ----- reportText ^ (report isNil or: [categoriesSelected isEmpty]) ifTrue: ['-- Choose any category on the left --'] ifFalse: [report]! ----- Method: SystemReporter>>reportTinyBenchmarks: (in category 'reporting') ----- reportTinyBenchmarks: aStream tinyBenchmarksResult ifNil: [ (UIManager default confirm: 'Running all benchmarks\might take a few seconds.' withCRs translated title: 'Continue?' translated) ifFalse: [ categoriesSelected remove: #'Tiny Benchmarks'. ^ self changed: #categorySelected ]. Cursor wait showWhile: [tinyBenchmarksResult := 0 tinyBenchmarks]]. self header: 'Tiny Benchmarks' on: aStream. aStream nextPutAll: tinyBenchmarksResult; cr! ----- Method: SystemReporter>>reportVM: (in category 'reporting') ----- reportVM: aStream self header: 'Virtual Machine' on: aStream. aStream nextPutAll: (Smalltalk vm vmFileName); cr; nextPutAll: (Smalltalk vm vmVersion); cr. Smalltalk vm buildDate ifNotNilDo: [:string | aStream nextPutAll: string; cr]. [Smalltalk vm platformSourceVersion ifNotNilDo: [:v | aStream nextPutAll: 'platform sources revision ', v; cr]] on: Warning do: ["unsupported primitive"]. [Smalltalk vm interpreterSourceVersion ifNotNilDo: [:v | aStream nextPutAll: 'VMMaker versionString ', v; cr]] on: Warning do: ["unsupported primitive"]. [Smalltalk vm interpreterClass ifNotNilDo: [:string | aStream nextPutAll: string; cr]. Smalltalk vm cogitClass ifNotNilDo: [:string | aStream nextPutAll: string; cr] ] on: Error do: ["unsupported primitives"] ! ----- Method: SystemReporter>>reportVMOptions: (in category 'reporting') ----- reportVMOptions: aStream self header: 'Virtual Machine Commandline Options' on: aStream. self enumerate: [:idx | Smalltalk vm optionAt: idx] startAt: 1 on: aStream! ----- Method: SystemReporter>>reportVMParameters: (in category 'reporting') ----- reportVMParameters: aStream | vmParameters isCog isSpur | self header: 'Virtual Machine Parameters' on: aStream. vmParameters := Smalltalk vm getVMParameters. isCog := (vmParameters at: 41 ifAbsent: [0]) anyMask: 1. "determine Cog/Stack via bit 0, requires native float order." isSpur := isCog and: [(vmParameters at: 41 ifAbsent: [0]) anyMask: 2r10000]. "bit 16 is the Spur bit" (isSpur ifFalse: [#( 1 'size of old space' 2 'size of young+old space' 3 'size of memory')] ifTrue: [#( 1 'size of old space' 2 'size of new space' 3 'size of heap')]), (isSpur ifFalse: [#( 4 'allocationCount' 5 'allocations between GCs' 6 'survivor count tenuring threshold')] ifTrue: [#()]), #( 7 'full GCs since startup' 8 'total milliseconds in full GCs since startup'), (isSpur ifFalse: [#( 9 'incremental GCs since startup' 10 'total milliseconds in incremental GCs since startup')] ifTrue: [#( 9 'scavenging GCs since startup' 10 'total milliseconds in scavenging GCs since startup')]), #( 11 'tenures of surving objects since startup'), (isCog ifFalse: [#( 12 'specific to the translating VM' 13 'specific to the translating VM' 14 'specific to the translating VM' 15 'specific to the translating VM' 16 'specific to the translating VM' 17 'specific to the translating VM' 18 'specific to the translating VM' 19 'specific to the translating VM' 20 'specific to the translating VM')] ifTrue: [{12 to: 20. 'specific to the translating VM'}]), #( 21 'root table size' 22 'root table overflows since startup' 23 'bytes of extra memory to reserve for VM buffers, plugins, etc.' 24 'memory threshold above which shrinking object memory' 25 'memory headroom when growing object memory'), (isCog ifFalse: [#( 26 'interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often')] ifTrue: [#( 26 'heartbeat period (ms)')]), (isSpur ifFalse: [#( 27 'number of times mark loop iterated for current IGC/FGC includes ALL marking' 28 'number of times sweep loop iterated for current IGC/FGC' 29 'number of times make forward loop iterated for current IGC/FGC' 30 'number of times compact move loop iterated for current IGC/FGC')] ifTrue: [#()]), #( 31 'number of grow memory requests' 32 'number of shrink memory requests'), (isSpur ifFalse: [#( 33 'number of root table entries used for current IGC/FGC' 34 'number of allocations done before current IGC/FGC' 35 'number of survivor objects after current IGC/FGC' 36 'millisecond clock when current IGC/FGC completed' 37 'number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC' 38 'milliseconds taken by current IGC ' 39 'Number of finalization signals for Weak Objects pending when current IGC/FGC completed')] ifTrue: [#( 36 'millisecond clock when current SGC/FGC completed' 38 'milliseconds taken by current SGC ' 39 'Number of finalization signals for Weak Objects pending when current SGC/FGC completed')]), #( 40 'VM word size - 4 or 8'), (isCog ifTrue: [#( 41 'imageFormatVersion for the VM' 42 'number of stack pages in use' 43 'desired number of stack pages (stored in image file header, max 65535)' 44 'size of eden, in bytes' 45 'desired size of eden, in bytes (stored in image file header)' 46 'machine code zone size, in bytes' 47 'desired machine code zone size (0 => default 1Mb)' 48 'various header flags. See getCogVMFlags.' 49 'max size the image promises to grow the external semaphore table to'), (isSpur ifFalse: [{ 50 to: 54. 'reserved for VM parameters that persist in the image (such as size of eden above)'. 55 to: 56. 'specific to Spur' }] ifTrue: [{ 50 to: 53. 'reserved for VM parameters that persist in the image (such as size of eden above)' }, #( 54 'total free old space' 55 'ratio of growth and image size at or above which a GC will be performed post scavenge')]), #( 56 'number of process switches since startup' 57 'number of ioProcessEvents calls since startup' 58 'number of forceInterruptCheck calls since startup' 59 'number of check event calls since startup' 60 'number of stack page overflows since startup' 61 'number of stack page divorces since startup' 62 'compiled code compactions since startup' 63 'total milliseconds in compiled code compactions since startup' 64 'the number of methods that currently have jitted machine-code' 65 'whether the VM supports MULTIPLE_BYTECODE_SETS or not.' 66 'the byte size of a stack page'), { 67 to: 69. 'reserved for more Cog-related info' }, #( 70 'the vmProxyMajorVersion (the interpreterProxy VM_MAJOR_VERSION)' 71 'the vmProxyMinorVersion (the interpreterProxy VM_MINOR_VERSION)')] ifFalse: [#()]) pairsDo: [:idx :desc | | value values | aStream nextPut: $#. idx isInteger ifTrue: [value := vmParameters at: idx. aStream print: idx; tab; nextPutAll: ((value isInteger and: [idx ~= 41]) ifTrue: [value asStringWithCommas] ifFalse: [value printString])] ifFalse: [value := vmParameters at: idx first. aStream print: idx first; next: 2 put: $.; print: idx last; tab. values := idx collect: [:i| vmParameters at: i]. values asSet size = 1 ifTrue: [aStream print: value] ifFalse: [values do: [:v| aStream print: v] separatedBy: [aStream nextPutAll: ', ']]]. aStream tab; nextPutAll: desc; cr]! ----- Method: SystemReporter>>reportVMStats: (in category 'reporting') ----- reportVMStats: aStream self header: 'Virtual Machine Statistics' on: aStream. aStream nextPutAll: Smalltalk vm vmStatisticsReportString! ----- Method: SystemReporter>>reportWin32GFXDetails: (in category 'reporting') ----- reportWin32GFXDetails: aStream self header: 'Graphics Hardware Details' on: aStream. aStream nextPutAll: (SmalltalkImage current getSystemAttribute: 10003)! ----- Method: SystemReporter>>reportWin32HardwareDetails: (in category 'reporting') ----- reportWin32HardwareDetails: aStream self header: 'Hardware Details' on: aStream. aStream nextPutAll: (SmalltalkImage current getSystemAttribute: 10001)! ----- Method: SystemReporter>>reportWin32OSDetails: (in category 'reporting') ----- reportWin32OSDetails: aStream self header: 'Operating System Details' on: aStream. aStream nextPutAll: (SmalltalkImage current getSystemAttribute: 10002)! ----- Method: SystemReporter>>reportWin32VMConfig: (in category 'reporting') ----- reportWin32VMConfig: aStream | exePath iniPath | self header: 'VM Configuration' on: aStream. exePath := Smalltalk vm vmFileName. iniPath := (exePath copyUpToLast: $.), '.ini'. aStream nextPutAll: iniPath; cr. self writeContentsSafelyFromFile: iniPath on: aStream. ! ----- Method: SystemReporter>>reportWorkingCopies: (in category 'reporting') ----- reportWorkingCopies: aStream | list | self header: 'Monticello Working Copies' on: aStream. list := MCWorkingCopy allManagers asSortedCollection: [:a :b | a name <= b name] . list do: [:each | aStream nextPutAll: each description; cr]! ----- Method: SystemReporter>>selectAllCategories (in category 'accessing-categories') ----- selectAllCategories categoriesSelected addAll: categoryList. self changed: #categorySelected. self updateReport! ----- Method: SystemReporter>>selectNoCategories (in category 'accessing-categories') ----- selectNoCategories categoriesSelected removeAll. self changed: #categorySelected. self updateReport! ----- Method: SystemReporter>>updateReport (in category 'updating') ----- updateReport report := Text streamContents: [:stream | stream withAttribute: (TextFontReference toFont: ((TextStyle named: 'BitstreamVeraSansMono') fontOfSize: 16)) do: [ self categoryList do: [:each | (categoriesSelected includes: each) ifTrue: [ self perform: ((categories at: each), ':') asSymbol with: stream. stream cr]]]]. self changed: #reportText! ----- Method: SystemReporter>>writeContentsSafelyFromFile:on: (in category 'private') ----- writeContentsSafelyFromFile: osPath on: aStream aStream nextPutAll: ([ (FileStream readOnlyFileNamed: osPath) upToEnd ] on: Error do: [:ex| ex return: ex printString])!

1 0

Squeak 4.6: GetText-mt.37.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of GetText to project Squeak 4.6: http://source.squeak.org/squeak46/GetText-mt.37.mcz ==================== Summary ==================== Name: GetText-mt.37 Author: mt Time: 10 May 2015, 1:57:01.667 pm UUID: 0033c111-0112-dd4f-95ac-0a56cc7a0f68 Ancestors: GetText-nice.36 Skip registering LanguageEditor in world menu for now because it is not functional at the moment. ==================== Snapshot ==================== SystemOrganization addCategory: #'GetText-Editor'! Object subclass: #GetTextExporter instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'GetText-Editor'! !GetTextExporter commentStamp: '<historical>' prior: 0! Export translations to gettext format divided into categories. "Export gettext template files" GetTextExporter new exportTemplate. "Export translation files for current locale" GetTextExporter new exportTranslator: (InternalTranslator newLocaleID: LocaleID current). "Export all gettext template and po files." GetTextExporter exportAll. ! ----- Method: GetTextExporter class>>coverageStatus (in category 'utilities') ----- coverageStatus "self coverageStatus" | keys diff | keys := self keys. diff := InternalTranslator allKnownPhrases keys difference: keys. Transcript cr; show: 'Detected keywords by GetTextExporter2: ' , keys size printString. Transcript cr; show: 'All known phrases in InternalTranslator: ' , InternalTranslator allKnownPhrases size printString. Transcript cr; show: 'Coverage: ' , (keys size / InternalTranslator allKnownPhrases size * 100.0) printString , '%'. diff inspect! ----- Method: GetTextExporter class>>exportAll (in category 'utilities') ----- exportAll "GetTextExporter2 exportAll" self new exportTemplate. InternalTranslator availableLanguageLocaleIDs do: [:each | self new exportTranslator: each translator]! ----- Method: GetTextExporter class>>exportTemplate (in category 'utilities') ----- exportTemplate "GetTextExporter2 exportTemplate" self new exportTemplate.! ----- Method: GetTextExporter class>>keys (in category 'utilities') ----- keys | categories | categories := Dictionary new. self new appendTranslations: categories. ^ categories values inject: Set new into: [:set :next | set addAll: next keys; yourself]! ----- Method: GetTextExporter class>>listAllHelp (in category 'utilities') ----- listAllHelp "self listAllHelp" | spec specs oCatalog flap flapSelectors allKeys oCatalogHelp flapHelp | oCatalog := Dictionary new. Morph withAllSubclasses do: [:aClass | (aClass class includesSelector: #descriptionForPartsBin) ifTrue: [spec := aClass descriptionForPartsBin. oCatalog at: spec formalName put: spec documentation]]. Morph withAllSubclasses do: [:aClass | (aClass class includesSelector: #supplementaryPartsDescriptions) ifTrue: [specs := aClass supplementaryPartsDescriptions. specs do: [:each | oCatalog at: each formalName put: each documentation]]]. flap := Dictionary new. flapSelectors := #(#defaultsQuadsDefiningPlugInSuppliesFlap #defaultsQuadsDefiningStackToolsFlap #defaultsQuadsDefiningSuppliesFlap #defaultsQuadsDefiningToolsFlap #defaultsQuadsDefiningWidgetsFlap #defaultsQuadsDefiningScriptingFlap ). flapSelectors do: [:selector | specs := Flaps perform: selector. specs do: [:each | flap at: each third put: each fourth]]. allKeys := oCatalog keys intersection: flap keys. allKeys asArray sort do: [:each | oCatalogHelp := oCatalog at: each ifAbsent: ['']. flapHelp := flap at: each ifAbsent: ['']. oCatalogHelp = flapHelp ifFalse: [Transcript cr; show: 'Name: ' , each. Transcript cr; show: 'O: ' , oCatalogHelp. Transcript cr; show: 'F: ' , flapHelp. Transcript cr. ]]! ----- Method: GetTextExporter class>>verifyExport (in category 'utilities') ----- verifyExport "Same as #verifyMsgID: but it writes / reads .po files actually" "GetTextExporter2 verifyExport" "InternalTranslator removeLocaleID: (LocaleID isoString: 'test-US')" | src dst localeID | localeID := LocaleID isoString: 'test-US'. self verifyMsgID: localeID. src := localeID translator. self new exportTranslator: src. InternalTranslator removeLocaleID: localeID. dst := localeID translator. GetTextImporter import: dst allDirectory: FileDirectory default! ----- Method: GetTextExporter class>>verifyMsgID: (in category 'utilities') ----- verifyMsgID: localeID "GetTextExporter2 verifyMsgID: (LocaleID isoString: 'test-US')" "InternalTranslator removeLocaleID: (LocaleID isoString: 'test-US')" "Test gettext keyword extract function without file I/O. A language named <langName> will be made. And all possible translated words are shown with extra X charactor like 'XwordX' in the language." | src | InternalTranslator removeLocaleID: localeID. src := localeID translator. self keys do: [:key | src generics at: key put: 'X' , key , 'X']! ----- Method: GetTextExporter>>appendStringReceivers:into: (in category 'private') ----- appendStringReceivers: aSymbol into: domains | literals references domainName methodReference keywords found | found := TranslatedReceiverFinder new stringReceiversWithContext: aSymbol. found do: [ :assoc | methodReference := assoc key. keywords := assoc value. domainName := (PackageOrganizer default packageOfMethod: methodReference ifNone: [nil]). domainName := domainName isNil ifTrue: [TextDomainManager defaultDomain] ifFalse: [domainName name]. literals := domains at: domainName ifAbsentPut: [Dictionary new]. keywords do: [ :literal | references := literals at: literal ifAbsentPut: [OrderedCollection new]. references add: methodReference. ]. ]. ! ----- Method: GetTextExporter>>appendTranslations: (in category 'exporting') ----- appendTranslations: domains self appendStringReceivers: #translated into: domains. self appendStringReceivers: #translatedNoop into: domains. self appendVocabularies: domains. ! ----- Method: GetTextExporter>>appendVocabularies: (in category 'private') ----- appendVocabularies: domains | literalsForDomain references domainName methodReference | EToyVocabulary allPhrasesWithContextToTranslate do: [ :r | methodReference := (MethodReference class: (r second) selector: (r third)). "domainName := self getTextDomainForPackage: (PackageOrganizer default packageOfMethod: methodReference)". domainName := 'Etoys-Tiles'. literalsForDomain := domains at: domainName ifAbsentPut: [Dictionary new]. r fourth do: [ :literal | references := literalsForDomain at: literal ifAbsentPut: [OrderedCollection new]. references add: methodReference. ]. ]. ! ----- Method: GetTextExporter>>createExtraInformation (in category 'private') ----- createExtraInformation | extras | extras := OrderedCollection new. #( 'Language name as you''d like it to appear in the Languages menu' 'Language-Name' 'Directionality of language' 'Language-Direction' ) pairsDo: [:first :second | extras add: (Array with: '' with: first with: second). ]. ^ extras! ----- Method: GetTextExporter>>createHeaders (in category 'private-headers') ----- createHeaders | headers | headers := OrderedCollection new. headers add: 'Project-Id-Version' -> 'eToys'. headers add: 'POT-Creation-Date' -> self currentDateAndTime. headers add: 'PO-Revision-Date' -> self currentDateAndTime. headers add: 'Last-Translator' -> ''. headers add: 'Language-Team' -> ''. headers add: 'MIME-Version' -> '1.0'. headers add: 'Content-Type' -> ('text/plain; charset=', stream converter class encodingNames first). headers add: 'Content-Transfer-Encoding' -> '8bit'. ^ headers! ----- Method: GetTextExporter>>currentDateAndTime (in category 'private') ----- currentDateAndTime ^ String streamContents: [:aStream | aStream nextPutAll: Date today yyyymmdd; space. Time now print24: true showSeconds: false on: aStream. aStream nextPutAll: '-0000']! ----- Method: GetTextExporter>>dirNameCategory:translator: (in category 'exporting') ----- dirNameCategory: category translator: translator "Answer a file name for the category. Make one if it is not exist yet. Make template file name if translator is nil" "self new dirNameCategory: 'Morphic-Scripting Support' translator: NaturalLanguageTranslator current" "self new dirNameCategory: 'Morphic-Scripting Support' translator: nil" | safeCategory fileName dirName pathName | safeCategory := category copyReplaceAll: ' ' with: ':='. fileName := translator ifNil: [safeCategory , '.pot'] ifNotNil: [translator localeID posixName , '.po']. dirName := (safeCategory findTokens: '-') inject: 'po' into: [:aString :next | aString , FileDirectory slash , next]. pathName := dirName , FileDirectory slash , fileName. (FileDirectory default directoryNamed: dirName) assureExistence. ^ pathName! ----- Method: GetTextExporter>>dirNameDomain:translator: (in category 'exporting') ----- dirNameDomain: domain translator: translator "Answer a file name for the domain. Make one if it is not exist yet. Make template file name if translator is nil" "self new dirNameDomain: 'etoys' translator: NaturalLanguageTranslator current" "self new dirNameDomain: 'etoys' translator: nil" | fileName dirName pathName | "safeCategory := category copyReplaceAll: ' ' with: ':='." fileName := domain, (translator ifNil: ['.pot'] ifNotNil: ['.po']). dirName := 'po', FileDirectory slash, (translator ifNil: ['templates'] ifNotNil: [translator localeID posixName]). pathName := dirName , FileDirectory slash , fileName. (FileDirectory default directoryNamed: dirName) assureExistence. ^ pathName! ----- Method: GetTextExporter>>export:translator:domain: (in category 'private') ----- export: literals translator: translator domain: domainName | fileName | "Export a gettext file in a category. literals is a dictionary of keyword -> #(MethodReference...) in the textDomain." fileName := self dirNameDomain: domainName translator: translator. [stream := FileStream forceNewFileNamed: fileName. stream lineEndConvention: #lf. stream converter: UTF8TextConverter new. self exportHeader: domainName. domainName = TextDomainManager defaultDomain ifTrue: [self exportInformation: self createExtraInformation]. self exportBody: literals translator: translator] ensure: [stream close]! ----- Method: GetTextExporter>>exportBody:translator: (in category 'file out') ----- exportBody: literals translator: translator "Export a gettext file body. literals is a dictionary of keyword -> #(MethodReference...) in the textDomain." "Build {sortKey. comment. msgid } to optimize sorting (getting category is too slow). If there are two or more methods for a mgsid, only first method (alphabetical) is used for sorting." | sorted msgid sortedMethods category sortKey comment triplets commentUnderLined | triplets := literals associations collect: [:assoc | msgid := assoc key. sortedMethods := assoc value asArray sort. category := (Smalltalk at: sortedMethods first classSymbol) category asString. sortKey := category , ',' , sortedMethods first printString , ',' , msgid. comment := (sortedMethods collect: [:each | each actualClass asString , '>>' , each methodSymbol asString]) inject: category into: [:result :methodName | result , ',' , methodName]. "Replace white spaces to := because gettext tool might replace a space to a new line some times, and it makes difficult to take a diff." commentUnderLined := comment copyReplaceAll: ' ' with: ':='. Array with: sortKey with: commentUnderLined with: msgid]. "Sort and output the words" sorted := triplets sort: [:a :b | a first <= b first]. sorted do: [:triplet | comment := triplet second. msgid := triplet third. self exportRecordHeader: comment. self exportPhrase: msgid translation: (self translationFor: msgid in: translator)]! ----- Method: GetTextExporter>>exportHeader (in category 'private-headers') ----- exportHeader self exportTag: 'msgid' msg: ''. self exportTag: 'msgstr' msg: ''. self createHeaders do: [:each | self exportHeaderLineKey: each key value: each value]. stream cr; cr! ----- Method: GetTextExporter>>exportHeader: (in category 'private') ----- exportHeader: domainName | headers | self exportTag: 'msgid' msg: ''. self exportTag: 'msgstr' msg: ''. headers := self createHeaders. headers add: 'X-Etoys-Domain' -> domainName. headers do: [:each | self exportHeaderLineKey: each key value: each value]. stream cr; cr! ----- Method: GetTextExporter>>exportHeaderLineKey:value: (in category 'private') ----- exportHeaderLineKey: keyString value: valueString stream nextPut: $"; nextPutAll: keyString; nextPut: $:; space; nextPutAll: valueString; nextPutAll: '\n'; nextPut: $"; cr.! ----- Method: GetTextExporter>>exportInformation: (in category 'private') ----- exportInformation: anOrderedCollection anOrderedCollection do: [:each | self exportRecordHeader: each second. self exportPhrase: each third translation: '']. stream cr.! ----- Method: GetTextExporter>>exportPhrase:translation: (in category 'private') ----- exportPhrase: phraseString translation: translationString | normalizedTrans tmp transStartsWithCR transEndsWithCR| phraseString isEmpty ifTrue: [^ self]. self exportTag: 'msgid' msg: phraseString. translationString size = 0 ifTrue: [ normalizedTrans := '' ] ifFalse: [ transEndsWithCR := translationString last = (Character cr). phraseString last = (Character cr) ifTrue: [ transEndsWithCR ifTrue: [ normalizedTrans := translationString ] ifFalse: [ normalizedTrans := translationString , String cr ] ] ifFalse: [ transEndsWithCR ifTrue: [ normalizedTrans := translationString allButLast ] ifFalse: [ normalizedTrans := translationString ] ]. transStartsWithCR := normalizedTrans first = (Character cr). phraseString first = (Character cr) ifTrue: [ transStartsWithCR ifFalse: [ tmp := (Character cr asString) , normalizedTrans. normalizedTrans := tmp. ] ] ifFalse: [ transStartsWithCR ifTrue: [ normalizedTrans := normalizedTrans allButFirst ] ] ]. self exportTag: 'msgstr' msg: normalizedTrans. stream cr! ----- Method: GetTextExporter>>exportRecordHeader: (in category 'private') ----- exportRecordHeader: context stream nextPutAll: '#: '; nextPutAll: context; cr.! ----- Method: GetTextExporter>>exportTag:msg: (in category 'private') ----- exportTag: tag msg: aString stream nextPutAll: tag. stream space. aString lineIndicesDo: [:start :endWithoutDelimiters :end | | line | line := (end = endWithoutDelimiters) ifTrue: [aString copyFrom: start to: endWithoutDelimiters] ifFalse: [(aString at: endWithoutDelimiters + 1) = Character cr ifTrue: [aString copyFrom: start to: endWithoutDelimiters + 1] ifFalse: [(aString copyFrom: start to: endWithoutDelimiters) copyWith: Character cr]]. stream nextPut: $"; nextPutAll: (self formatString: line); nextPut: $"; cr].! ----- Method: GetTextExporter>>exportTemplate (in category 'exporting') ----- exportTemplate "GetTextExporter2 new exportTemplate" self exportTranslator: nil! ----- Method: GetTextExporter>>exportTranslator: (in category 'exporting') ----- exportTranslator: translator "Export translation files. the file extention is 'po', or 'pot' if translator is nil " "GetTextExporter2 new exportTranslator: NaturalLanguageTranslator current " | domains | domains := Dictionary new. self appendTranslations: domains. domains keysAndValuesDo: [:domainName :value | self export: value translator: translator domain: domainName]! ----- Method: GetTextExporter>>formatReplacements (in category 'private') ----- formatReplacements | replacements | replacements := OrderedCollection new. replacements add: '\' -> '\\'. replacements add: String cr -> '\n'. replacements add: String tab -> '\t'. replacements add: '"' -> '\"'. ^ replacements! ----- Method: GetTextExporter>>formatString: (in category 'private') ----- formatString: aString | result | result := aString. self formatReplacements do: [:each | result := result copyReplaceAll: each key with: each value]. ^ result! ----- Method: GetTextExporter>>getTextDomainForPackage: (in category 'as yet unclassified') ----- getTextDomainForPackage: aPackageInfo ^TextDomainManager domainForPackage: aPackageInfo! ----- Method: GetTextExporter>>stream (in category 'accessing') ----- stream ^ stream! ----- Method: GetTextExporter>>stream: (in category 'accessing') ----- stream: aStream stream := aStream! ----- Method: GetTextExporter>>translationFor:in: (in category 'private') ----- translationFor: aKey in: translator | translation | translator ifNil: [^ '']. TextDomainManager allKnownDomains do: [:domain | translation := translator translate: aKey inDomain: domain. aKey = translation ifFalse: [^translation] ]. ^ aKey! Object subclass: #GetTextInterchange instanceVariableNames: 'language stream' classVariableNames: '' poolDictionaries: '' category: 'GetText-Editor'! GetTextInterchange subclass: #GetTextImporter instanceVariableNames: 'msgId msgStr state' classVariableNames: '' poolDictionaries: '' category: 'GetText-Editor'! !GetTextImporter commentStamp: 'tak 10/24/2007 11:23' prior: 0! GetTextImporter load gettext po file into a InternalTranslator. GetTextImporter new importID: (LocaleID isoString: 'lang-name') fileNamed: 'lang.po' ! ----- Method: GetTextImporter class>>cleanUpUnnecessaryPhrases (in category 'utilities') ----- cleanUpUnnecessaryPhrases | keys refuse replaceBlock reader writer char result | "GetTextImporter cleanUpUnnecessaryPhrases" "" "Collect wrong phrases" keys := InternalTranslator allKnownPhrases copy keys. refuse := Set new. "replaceBlock value: 'te\\nst'." replaceBlock := [:aString | reader := aString readStream. writer := '' writeStream. [reader atEnd] whileFalse: [char := reader next. (char = $\ and: [reader peek = $\]) ifFalse: [writer nextPut: char]]. writer contents]. keys do: [:each | result := replaceBlock value: each. (result ~= each and: [keys includes: result]) ifTrue: [refuse add: each]. result := GetTextImporter new formatString: each. (result ~= each and: [keys includes: result]) ifTrue: [refuse add: each]]. "" "Remove from translated" InternalTranslator cachedTranslations do: [:each | refuse do: [:key | each translations removeKey: key ifAbsent: []]]. "" "Remove from untranslated" refuse do: [:key | InternalTranslator allKnownPhrases removeKey: key ifAbsent: []]! ----- Method: GetTextImporter class>>import:allDirectory: (in category 'utilities') ----- import: translator allDirectory: aFileDirectory "self import: NaturalLanguageTranslator current allDirectory: FileDirectory default" | fileName targetFile | fileName := translator localeID posixName , '.po'. (FileDirectory default directoryNamed: 'po') withAllSubdirectoriesCollect: [:each | (each fileExists: fileName) ifTrue: [targetFile := each fullNameFor: fileName. self new import: translator fileNamed: targetFile]]! ----- Method: GetTextImporter class>>importAll (in category 'utilities') ----- importAll "GetTextImporter importAll" "Import all gettext files on po/. Only registered language is imported" InternalTranslator cachedTranslations do: [:translator | self import: translator allDirectory: FileDirectory default]! ----- Method: GetTextImporter>>appendId: (in category 'parsing') ----- appendId: aString msgId := msgId , aString! ----- Method: GetTextImporter>>appendStr: (in category 'parsing') ----- appendStr: aString msgStr := msgStr , aString! ----- Method: GetTextImporter>>formatString: (in category 'private') ----- formatString: aString " self assert: (GetTextImporter new formatString: 'test') = 'test'. self assert: (GetTextImporter new formatString: 'te\nst') = ('te', String cr, 'st'). self assert: (GetTextImporter new formatString: 'te\\nst') = ('te\nst'). self assert: (GetTextImporter new formatString: 'te\\st') = ('te\st'). self assert: (GetTextImporter new formatString: 'te\st') = ('te\st'). " | reader writer char | reader := aString readStream. writer := '' writeStream. [reader atEnd] whileFalse: [char := reader next. (char = $\ and: [reader atEnd not]) ifTrue: [char := reader next. char caseOf: { [$n] -> [writer nextPut: Character cr]. [$t] -> [writer nextPut: Character tab]. [$"] -> [writer nextPut: $"]. [$\] -> [writer nextPut: $\]} otherwise: [writer nextPutAll: {$\. char}]] ifFalse: [writer nextPut: char]]. ^ writer contents! ----- Method: GetTextImporter>>import: (in category 'importing') ----- import: aLanguage ^ self import: aLanguage fileNamed: aLanguage localeID posixName , '.po'! ----- Method: GetTextImporter>>import:fileNamed: (in category 'importing') ----- import: aLanguage fileNamed: fileName self importID: aLanguage localeID fileNamed: fileName! ----- Method: GetTextImporter>>importID:fileNamed: (in category 'importing') ----- importID: localeID fileNamed: fileName | currentPlatform | language := InternalTranslator newLocaleID: localeID. currentPlatform := Locale currentPlatform. [Locale currentPlatform: (Locale localeID: localeID). [stream := FileStream readOnlyFileNamed: fileName. stream text. self parse] ensure: [stream notNil ifTrue: [stream close]]] ensure: [Locale currentPlatform: currentPlatform]. NaturalLanguageTranslator privateStartUp "Actually it is not private no more...".! ----- Method: GetTextImporter>>initialize (in category 'initialize-release') ----- initialize msgId := ''. msgStr := ''. state := nil! ----- Method: GetTextImporter>>parse (in category 'parsing') ----- parse | size | size := (stream isKindOf: FileStream) ifTrue: [stream size] ifFalse: [1]. ProgressInitiationException display: 'Importing phrases from a gettext file.' during: [:bar | [stream atEnd] whileFalse: [| line | line := stream upTo: Character linefeed. self parseLine: ((line endsWith: String cr) ifTrue: [line allButLast] ifFalse: [line]). bar value: stream position / size]]. self storeTranslation! ----- Method: GetTextImporter>>parseLine: (in category 'parsing') ----- parseLine: lineString (lineString beginsWith: '"Content-Type:') ifTrue: [self setContentType: lineString. ^ self]. (lineString beginsWith: '#') ifTrue: ["do nothing" ^ self]. lineString = '' ifTrue: [^ self storeTranslation]. (lineString beginsWith: 'msgid') ifTrue: [state := #appendId:. self parseMsg: lineString. ^ self]. (lineString beginsWith: 'msgstr') ifTrue: [state := #appendStr:. self parseMsg: lineString. ^ self]. self parseMsg: lineString! ----- Method: GetTextImporter>>parseMsg: (in category 'parsing') ----- parseMsg: lineString | begin end msg | begin := lineString indexOf: $". end := lineString lastIndexOf: $". msg := begin + 1 <= (end - 1) ifTrue: [lineString copyFrom: begin + 1 to: end - 1] ifFalse: ['']. state ifNotNil: [self perform: state with: msg]. ^ msg! ----- Method: GetTextImporter>>setContentType: (in category 'parsing') ----- setContentType: lineString "self new setContentType: 'Content-Type: text/plain; charset=utf-8'" | reader charSet | reader := lineString readStream. reader upTo: $=. charSet := reader upTo: $\. stream converter: (TextConverter newForEncoding: charSet)! ----- Method: GetTextImporter>>storeTranslation (in category 'parsing') ----- storeTranslation | key | key := self formatString: msgId. msgId isEmpty ifFalse: [InternalTranslator registerPhrase: key. msgStr isEmpty ifFalse: [language rawPhrase: key translation: (self formatString: msgStr)]]. self initialize! ----- Method: GetTextInterchange>>defaultFileName (in category 'private') ----- defaultFileName ^ language localeID posixName , '.po'! ----- Method: GetTextInterchange>>language: (in category 'accessing') ----- language: translator language := translator! ----- Method: GetTextInterchange>>stream (in category 'accessing') ----- stream ^ stream! ----- Method: GetTextInterchange>>stream: (in category 'accessing') ----- stream: aStream stream := aStream! SystemWindow subclass: #LanguageEditor instanceVariableNames: 'translator translations untranslated selectedTranslation selectedTranslations selectedUntranslated translationsList untranslatedList translationText translationsFilter untranslatedFilter newerKeys' classVariableNames: 'CheckMethods' poolDictionaries: '' category: 'GetText-Editor'! !LanguageEditor commentStamp: 'dgd 11/16/2003 15:02' prior: 0! Editor for Babel's languages. Open it from World Menu >> open... >> Language Editor (to open on default language) World Menu >> open... >> Language Editor for... (to choose the language) Or click: LanguageEditor openOnDefault. LanguageEditor open. See http://swiki.agro.uba.ar/small_land/191 for documentation ! ----- Method: LanguageEditor class>>checkMethods (in category 'private') ----- checkMethods ^CheckMethods ifNil: [CheckMethods := self initCheckMethods]! ----- Method: LanguageEditor class>>ensureVisibilityOfWindow: (in category 'private') ----- ensureVisibilityOfWindow: aWindow "private - activate the window" | | aWindow expand. aWindow comeToFront. "" aWindow right: (aWindow right min: World right). aWindow bottom: (aWindow bottom min: World bottom). aWindow left: (aWindow left max: World left). aWindow top: (aWindow top max: World top). "" aWindow flash; flash! ----- Method: LanguageEditor class>>initCheckMethods (in category 'initialize-release') ----- initCheckMethods "LanguageEditor initCheckMethods" | registry | registry := Dictionary new. registry at: 'es' put: #checkSpanishPhrase:translation:; yourself. ^registry! ----- Method: LanguageEditor class>>initialize (in category 'initialize-release') ----- initialize "initialize the receiver" "(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ TheWorldMenu registerOpenCommand: {'Language Editor' translated. {self. #openOnDefault}}. TheWorldMenu registerOpenCommand: {'Language Editor for...' translated. {self. #open}}]"! ----- Method: LanguageEditor class>>on: (in category 'instance creation') ----- on: localeID "answer an instance of the receiver on aLanguage" ^ self new initializeOn: (InternalTranslator cachedTranslations at: localeID ifAbsent: [self inform: ('Translator for {1} is not found' translated format: {localeID}). ^nil])! ----- Method: LanguageEditor class>>open (in category 'opening') ----- open "open the receiver on any language" " LanguageEditor open. " | menu availableLanguages | menu := MenuMorph new defaultTarget: self. menu addTitle: 'Language Editor for...' translated. "" availableLanguages := (InternalTranslator availableLanguageLocaleIDs asSortedCollection: [:x :y | x asString <= y asString]). availableLanguages ifEmpty:[^self inform:'InternalTranslator not initialized']. availableLanguages do: [:eachLanguage | "" menu add: eachLanguage name target: self selector: #openOn: argument: eachLanguage]. "" menu popUpInWorld! ----- Method: LanguageEditor class>>openOn: (in category 'instance creation') ----- openOn: aLanguage "open an instance on aLanguage" | editor | World submorphs do: [:each | "" ((each isKindOf: LanguageEditor) and: [each translator == aLanguage]) ifTrue: ["" self ensureVisibilityOfWindow: each. ^ self]]. "" editor := self on: aLanguage. editor ifNotNil:[^editor openInWorld]! ----- Method: LanguageEditor class>>openOnDefault (in category 'opening') ----- openOnDefault "open the receiver on the default language" self openOn: LocaleID current! ----- Method: LanguageEditor class>>unload (in category 'initialize-release') ----- unload "the receiver is being unloaded" (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: ["" TheWorldMenu unregisterOpenCommand: 'Language Editor'. TheWorldMenu unregisterOpenCommand: 'Language Editor for...'] ! ----- Method: LanguageEditor>>addTranslation (in category 'gui methods') ----- addTranslation "translate a phrase" | phrase | phrase := UIManager default request: 'enter the original:' translated initialAnswer: ''. (phrase isNil or: [phrase = '']) ifTrue: [ self beep. ^ self]. self translatePhrase: phrase! ----- Method: LanguageEditor>>applyTranslations (in category 'gui methods') ----- applyTranslations "private - try to apply the translations as much as possible all over the image" Project current updateLocaleDependents! ----- Method: LanguageEditor>>asHtml: (in category 'reporting') ----- asHtml: aString | stream | stream := String new writeStream. aString do: [:each | each caseOf: { [Character cr] -> [stream nextPutAll: '<br>']. [$&] -> [stream nextPutAll: '&']. [$<] -> [stream nextPutAll: '<']. [$>] -> [stream nextPutAll: '>']. [$*] -> [stream nextPutAll: '&star;']. [$@] -> [stream nextPutAll: '&at;']} otherwise: [stream nextPut: each]]. ^ stream contents! ----- Method: LanguageEditor>>browseMethodsWithTranslation (in category 'gui methods') ----- browseMethodsWithTranslation | translation | self selectedTranslation isZero ifTrue: ["" self beep. self inform: 'select the translation to look for' translated. ^ self]. "" translation := self translations at: self selectedTranslation. self systemNavigation browseMethodsWithLiteral: translation! ----- Method: LanguageEditor>>browseMethodsWithUntranslated (in category 'gui methods') ----- browseMethodsWithUntranslated | untrans | self selectedUntranslated isZero ifTrue: ["" self beep. self inform: 'select the untrans phrase to look for' translated. ^ self]. "" untrans := self untranslated at: self selectedUntranslated. SystemNavigation default browseMethodsWithLiteral: untrans. ! ----- Method: LanguageEditor>>check (in category 'private') ----- check "check the translations and answer a collection with the results" | results counter phrasesCount checkMethod | results := OrderedCollection new. untranslated := self untranslated. phrasesCount := self translations size + self untranslated size. counter := 0. checkMethod := self class checkMethods at: self translator localeID printString ifAbsent: [^results]. self translations keysAndValuesDo: [:phrase :translation | | result | result := self perform: checkMethod with: phrase with: translation. (result notNil and: [result notEmpty]) ifTrue: [results add: {phrase. translation. result}]. counter := counter + 1. (counter isDivisibleBy: 50) ifTrue: [| percent | percent := counter / phrasesCount * 100 printShowingMaxDecimalPlaces: 2. Transcript show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); cr]]. self untranslated do: [:phrase | | result | result := self checkUntranslatedPhrase: phrase. (result notNil and: [result notEmpty]) ifTrue: [results add: {phrase. nil. result}]. counter := counter + 1. (counter isDivisibleBy: 50) ifTrue: [| percent | percent := counter / phrasesCount * 100 printShowingMaxDecimalPlaces: 2. Transcript show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); cr]]. ^ results! ----- Method: LanguageEditor>>checkPhrase:translation: (in category 'private') ----- checkPhrase: phraseString translation: translationString ^nil! ----- Method: LanguageEditor>>checkSpanishPhrase:translation: (in category 'private') ----- checkSpanishPhrase: phraseString translation: translationString "check the translation and aswer a string with a comment or a nil meaning no-comments" | superResult | superResult := self checkPhrase: phraseString translation: translationString. superResult isNil ifFalse: [^ superResult]. "For some reason, MCInstaller couldn't read Spanish character. " "((translationString includes: $?) and: [(translationString includes: $ø) not]) ifTrue: [^ 'øOlvidÛ el signo de pregunta?']. ((translationString includes: $!!) and: [(translationString includes: $°) not]) ifTrue: [^ 'øOlvidÛ el signo de admiraciÛn?']. " ^ nil ! ----- Method: LanguageEditor>>checkUntranslatedPhrase: (in category 'private') ----- checkUntranslatedPhrase: phraseString "check the phrase an aswer a string with a comment or a nil meaning no-comments" (self translations includes: phraseString) ifTrue: [^ 'possible double-translation' translated]. ^ nil! ----- Method: LanguageEditor>>codeSelectedTranslation (in category 'gui methods') ----- codeSelectedTranslation | keys code | keys := selectedTranslations collect: [:key | self translations at: key]. code := String streamContents: [:aStream | self translator fileOutOn: aStream keys: keys withBOM: false]. (StringHolder new contents: code) openLabel: 'exported codes' translated! ----- Method: LanguageEditor>>codeSelectedTranslationAsMimeString (in category 'gui methods') ----- codeSelectedTranslationAsMimeString | keys code cont | keys := selectedTranslations collect: [:key | self translations at: key]. code := String streamContents: [:aStream | self translator fileOutOn: aStream keys: keys withBOM: false]. cont := String streamContents: [:strm | strm nextPutAll: '"UTF8+Gzip+Base64 encoded translation for;'; cr. strm nextPutAll: '#('. keys do: [:each | strm nextPutAll: '''', each, ''' '.]. strm nextPutAll: ')"'; cr; cr. strm nextPutAll: 'NaturalLanguageTranslator loadForLocaleIsoString: '. strm nextPut: $'. strm nextPutAll: translator localeID isoString. strm nextPut: $'. strm nextPutAll: ' fromGzippedMimeLiteral: '. strm nextPut: $'. strm nextPutAll: code squeakToUtf8 asByteArray zipped base64Encoded. strm nextPutAll: '''.'. strm cr. ]. (StringHolder new contents: cont) openLabel: 'exported codes in UTF8+Gzip+Base64 encoding' translated! ----- Method: LanguageEditor>>createButtonLabel:action:help: (in category 'initialization - toolbar') ----- createButtonLabel: aString action: actionSelector help: helpString "create a toolbar for the receiver" | button | button := SimpleButtonMorph new target: self; label: aString translated "font: Preferences standardButtonFont"; actionSelector: actionSelector; setBalloonText: helpString translated; color: translator defaultBackgroundColor twiceDarker; borderWidth: 2; borderColor: #raised. "" ^ button! ----- Method: LanguageEditor>>createMainToolbar (in category 'initialization - toolbar') ----- createMainToolbar "create a toolbar for the receiver" | toolbar | toolbar := self createRow. "" " toolbar addMorphBack: (self createUpdatingButtonWording: #debugWording action: #switchDebug help: 'Switch the debug flag')." toolbar addTransparentSpacerOfSize: 5 @ 0. "" toolbar addMorphBack: (self createButtonLabel: 'new' action: #newTranslations help: 'Create translations for new language.'). toolbar addMorphBack: (self createButtonLabel: 'save' action: #saveToFile help: 'Save the translations to a file'). toolbar addMorphBack: (self createButtonLabel: 'load' action: #loadFromFile help: 'Load the translations from a file'). toolbar addMorphBack: (self createButtonLabel: 'merge' action: #mergeFromFile help: 'Merge the current translations with the translations in a file'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'apply' action: #applyTranslations help: 'Apply the translations as much as possible.'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'check translations' action: #check help: 'Check the translations and report the results.'). toolbar addMorphBack: (self createButtonLabel: 'report' action: #report help: 'Create a report.'). toolbar addMorphBack: (self createButtonLabel: 'gettext' action: #getText help: 'Interface with gettext.'). "" ^ toolbar! ----- Method: LanguageEditor>>createRow (in category 'initialization - toolbar') ----- createRow "create a row" | row | row := AlignmentMorph newRow. row layoutInset: 3; wrapCentering: #center; cellPositioning: #leftCenter. "" ^ row! ----- Method: LanguageEditor>>createStatusbar (in category 'initialization - statusbar') ----- createStatusbar "create the statusbar for the receiver" | statusbar | statusbar := self createRow. statusbar addMorph: ((UpdatingStringMorph on: self selector: #status) growable: true; useStringFormat; hResizing: #spaceFill; stepTime: 2000). ^ statusbar! ----- Method: LanguageEditor>>createTranslationsToolbar (in category 'initialization - toolbar') ----- createTranslationsToolbar "create a toolbar for the receiver" | toolbar | toolbar := self createRow. "" toolbar addMorphBack: (self createUpdatingButtonWording: #translationsFilterWording action: #filterTranslations help: 'Filter the translations list.'). toolbar addTransparentSpacerOfSize: 5 @ 0. "" toolbar addMorphBack: (self createButtonLabel: 'search' action: #searchTranslation help: 'Search for a translation containing...'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'remove' action: #removeTranslation help: 'Remove the selected translation. If none is selected, ask for the one to remove.'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'where' action: #browseMethodsWithTranslation help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'r-unused' action: #removeTranslatedButUnusedStrings help: 'Remove all the strings that are not used by the system'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'add ' action: #addTranslation help: 'Add a new phrase'). ^ toolbar! ----- Method: LanguageEditor>>createUntranslatedToolbar (in category 'initialization - toolbar') ----- createUntranslatedToolbar "create a toolbar for the receiver" | toolbar | toolbar := self createRow. "" toolbar addMorphBack: (self createUpdatingButtonWording: #untranslatedFilterWording action: #filterUntranslated help: 'Filter the untranslated list.'). toolbar addTransparentSpacerOfSize: 5 @ 0. "" toolbar addMorphBack: (self createButtonLabel: 'search' action: #searchUntranslated help: 'Search for a untranslated phrase containing...'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'remove' action: #removeUntranslated help: 'Remove the selected untranslated phrease. If none is selected, ask for the one to remove.'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'translate' action: #translate help: 'Translate the selected untranslated phrase or a new phrase'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'where' action: #browseMethodsWithUntranslated help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'r-unused' action: #removeUntranslatedButUnusedStrings help: 'Remove all the strings that are not used by the system'). ^ toolbar! ----- Method: LanguageEditor>>createUpdatingButtonWording:action:help: (in category 'initialization - toolbar') ----- createUpdatingButtonWording: wordingSelector action: actionSelector help: helpString "create a toolbar for the receiver" | button | button := (UpdatingSimpleButtonMorph newWithLabel: '-') target: self; wordingSelector: wordingSelector; actionSelector: actionSelector; setBalloonText: helpString translated; color: translator defaultBackgroundColor twiceDarker; borderWidth: 1; borderColor: #raised; cornerStyle: #square. "" ^ button! ----- Method: LanguageEditor>>delete (in category 'open/close') ----- delete "Remove the receiver as a submorph of its owner" self model: nil. super delete ! ----- Method: LanguageEditor>>deselectAllTranslation (in category 'gui methods') ----- deselectAllTranslation selectedTranslations := IdentitySet new. self changed: #allSelections! ----- Method: LanguageEditor>>filterTranslations (in category 'gui methods') ----- filterTranslations | filter | filter := UIManager default request: 'filter with (empty string means no-filtering)' translated initialAnswer: self translationsFilter. self filterTranslations: filter! ----- Method: LanguageEditor>>filterTranslations: (in category 'gui methods') ----- filterTranslations: aString | filter | filter := aString ifNil:['']. "" translationsFilter := filter. self refreshTranslations. ! ----- Method: LanguageEditor>>filterUntranslated (in category 'gui methods') ----- filterUntranslated | filter | filter := UIManager default request: 'filter with (empty string means no-filtering)' translated initialAnswer: self untranslatedFilter. self filterUntranslated: filter! ----- Method: LanguageEditor>>filterUntranslated: (in category 'gui methods') ----- filterUntranslated: aString | filter | filter := aString ifNil: ['']. "" untranslatedFilter := filter. self refreshUntranslated! ----- Method: LanguageEditor>>getText (in category 'gui methods') ----- getText | menu | menu := MenuMorph new defaultTarget: self. "" menu add: 'gettext template' translated target: self selector: #getTextExportTemplate. menu lastItem setBalloonText: 'exports the translations to gettext separated format.' translated. menu add: 'gettext export' translated target: self selector: #getTextExport. menu lastItem setBalloonText: 'Exports the translations to GetText format.' translated. "" menu add: 'gettext import' translated target: self selector: #getTextImport. menu lastItem setBalloonText: 'Imports the translations from GetText format.' translated. "" menu popUpInWorld! ----- Method: LanguageEditor>>getTextExport (in category 'gui methods') ----- getTextExport Cursor wait showWhile: [GetTextExporter new exportTranslator: self model]! ----- Method: LanguageEditor>>getTextExportTemplate (in category 'gui methods') ----- getTextExportTemplate Cursor wait showWhile: [GetTextExporter new exportTemplate] ! ----- Method: LanguageEditor>>getTextImport (in category 'gui methods') ----- getTextImport | menu | menu := MenuMorph new defaultTarget: self. menu addTitle: 'Choose translation file' translated. menu add: 'All *.po files' translated action: #getTextImportAll. menu add: 'Choose a file' translated action: #getTextImportAFile. menu popUpInWorld! ----- Method: LanguageEditor>>getTextImportAFile (in category 'gui methods') ----- getTextImportAFile | result | result := (StandardFileMenu new pattern: '*.po'; oldFileFrom: (FileDirectory default directoryNamed: 'po')) startUpWithCaption: 'Select a File:' translated. result ifNil: [^ self]. self withUnboundModelDo: [:trans | Cursor wait showWhile: [GetTextImporter new import: trans fileNamed: (result directory fullNameFor: result name)]]! ----- Method: LanguageEditor>>getTextImportAll (in category 'gui methods') ----- getTextImportAll self withUnboundModelDo: [:trans | Cursor wait showWhile: [GetTextImporter import: trans allDirectory: FileDirectory default]]. self refreshBoth! ----- Method: LanguageEditor>>identifyUnusedStrings (in category 'stef') ----- identifyUnusedStrings "self new identifyUnusedStrings" translationsList getList do: [:each | Transcript show: each. Transcript show: (Smalltalk allSelect: [:method | method hasLiteralSuchThat: [:lit | lit isString and: [lit includesSubstring: each caseSensitive: true]]]) size printString; cr]! ----- Method: LanguageEditor>>initializeNewerKeys (in category 'initialization') ----- initializeNewerKeys newerKeys := Set new. ! ----- Method: LanguageEditor>>initializeOn: (in category 'initialization') ----- initializeOn: aLanguage "initialize the receiver on aLanguage" "" selectedTranslation := 0. selectedUntranslated := 0. selectedTranslations := IdentitySet new. "" translator := aLanguage. "" self model: aLanguage. self setLabel: 'Language editor for: ' translated , self translator name. "" self initializeToolbars. self initializePanels. self initializeStatusbar. self initializeNewerKeys. ! ----- Method: LanguageEditor>>initializePanels (in category 'initialization') ----- initializePanels "initialize the receiver's panels" translationsList := PluggableListMorphOfMany on: self list: #translations primarySelection: #selectedTranslation changePrimarySelection: #selectedTranslation: listSelection: #selectedTranslationsAt: changeListSelection: #selectedTranslationsAt:put: menu: #translationsMenu: keystroke: #translationsKeystroke:. translationsList setBalloonText: 'List of all the translated phrases.' translated. "" untranslatedList := PluggableListMorph on: self list: #untranslated selected: #selectedUntranslated changeSelected: #selectedUntranslated: menu: #untranslatedMenu: keystroke: #untranslatedKeystroke:. untranslatedList setBalloonText: 'List of all the untranslated phrases.' translated. "" translationText := PluggableTextMorph on: self text: #translation accept: #translation: readSelection: nil menu: nil. translationText setBalloonText: 'Translation for the selected phrase in the upper list.' translated. "" self addMorph: translationsList frame: (0 @ 0.18 corner: 0.5 @ 0.66). self addMorph: untranslatedList frame: (0.5 @ 0.18 corner: 1 @ 0.93). self addMorph: translationText frame: (0 @ 0.66 corner: 0.5 @ 0.93). self hResizing: #shrinkWrap! ----- Method: LanguageEditor>>initializeStatusbar (in category 'initialization - statusbar') ----- initializeStatusbar "initialize the receiver's statusbar" self addMorph: self createStatusbar frame: (0 @ 0.93 corner: 1 @ 1)! ----- Method: LanguageEditor>>initializeToolbars (in category 'initialization - toolbar') ----- initializeToolbars "initialize the receiver's toolbar" self addMorph: self createMainToolbar frame: (0 @ 0 corner: 1 @ 0.09). "" self addMorph: self createTranslationsToolbar frame: (0 @ 0.09 corner: 0.5 @ 0.18). self addMorph: self createUntranslatedToolbar frame: (0.5 @ 0.09 corner: 1 @ 0.18)! ----- Method: LanguageEditor>>loadFromFile (in category 'gui methods') ----- loadFromFile | fileName | fileName := self selectTranslationFileName. fileName isNil ifTrue: ["" self beep. ^ self]. "" Cursor wait showWhile: [ self translator loadFromFileNamed: fileName. self refreshBoth]! ----- Method: LanguageEditor>>mergeFromFile (in category 'gui methods') ----- mergeFromFile | fileName | fileName := self selectTranslationFileName. fileName isNil ifTrue: ["" self beep. ^ self]. "" Cursor wait showWhile: [ self translator loadFromFileNamed: fileName. self refreshBoth]! ----- Method: LanguageEditor>>newTranslations (in category 'gui methods') ----- newTranslations "private - try to apply the translations as much as possible all over the image" | result newID | result := UIManager default request: 'New locale ID string?' translated initialAnswer: Locale current determineLocaleID isoString. result isEmpty ifTrue: ["Do nothing" ^ self]. newID := LocaleID isoString: result. InternalTranslator newLocaleID: (LocaleID isoString: result). self class openOn: newID! ----- Method: LanguageEditor>>numberOfTimesStringIsUsed: (in category 'stef') ----- numberOfTimesStringIsUsed: aString ^ (self systemNavigation allSelect: [:method | method hasLiteralSuchThat: [:lit | lit isString and: [lit includesSubstring: aString caseSensitive: true]]]) size! ----- Method: LanguageEditor>>okToChange (in category 'updating') ----- okToChange "Allows a controller to ask this of any model" self selectedTranslation isZero ifTrue: [^ true]. "" translationText hasUnacceptedEdits ifFalse: [^ true]. ^ (CustomMenu confirm: 'Discard the changes to currently selected translated phrase?' translated) and: ["" translationText hasUnacceptedEdits: false. true]! ----- Method: LanguageEditor>>perform:orSendTo: (in category 'message handling') ----- perform: selector orSendTo: otherTarget "I wish to intercept and handle selector myself" ^ self perform: selector! ----- Method: LanguageEditor>>phrase:translation: (in category 'gui methods') ----- phrase: phraseString translation: translationString "set the models's translation for phraseString" self translator phrase: phraseString translation: translationString. self refreshBoth. newerKeys add: phraseString. ! ----- Method: LanguageEditor>>phraseToTranslate (in category 'gui methods') ----- phraseToTranslate "answer a phrase to translate. use the selected untranslated phrase or ask for a new one" ^ self selectedUntranslated isZero ifTrue: [UIManager default multiLineRequest: 'new phrase to translate' translated centerAt: Sensor cursorPoint initialAnswer: '' answerHeight: 200] ifFalse: [self untranslated at: self selectedUntranslated]! ----- Method: LanguageEditor>>printHeaderReportOn: (in category 'reporting') ----- printHeaderReportOn: aStream "append to aStream a header report of the receiver with swiki format" aStream nextPutAll: '!!!!'; nextPutAll: ('Language: {1}' translated format: {self translator localeID isoString}); cr. aStream nextPutAll: '- '; nextPutAll: ('{1} translated phrases' translated format: {self translator translations size}); cr. aStream nextPutAll: '- '; nextPutAll: ('{1} untranslated phrases' translated format: {self translator untranslated size}); cr. aStream cr; cr! ----- Method: LanguageEditor>>printReportOn: (in category 'reporting') ----- printReportOn: aStream "append to aStream a report of the receiver with swiki format" self printHeaderReportOn: aStream. self printUntranslatedReportOn: aStream. self printTranslationsReportOn: aStream! ----- Method: LanguageEditor>>printTranslationsReportOn: (in category 'reporting') ----- printTranslationsReportOn: aStream "append to aStream a report of the receiver's translations" | originalPhrases | aStream nextPutAll: '!!'; nextPutAll: 'translations' translated; cr. originalPhrases := self translator translations keys asSortedCollection. originalPhrases do: [:each | aStream nextPutAll: ('|{1}|{2}|' format: {self asHtml: each. self asHtml: (self translator translate: each)}); cr]. aStream cr; cr! ----- Method: LanguageEditor>>printUntranslatedReportOn: (in category 'reporting') ----- printUntranslatedReportOn: aStream "append to aStream a report of the receiver's translations" aStream nextPutAll: '!!'; nextPutAll: 'not translated' translated; cr. self untranslated asSortedCollection do: [:each | aStream nextPutAll: ('|{1}|' format: {self asHtml: each}); cr]. aStream cr; cr! ----- Method: LanguageEditor>>refreshBoth (in category 'updating') ----- refreshBoth self refreshUntranslated ! ----- Method: LanguageEditor>>refreshTranslations (in category 'updating') ----- refreshTranslations "refresh the translations panel" self selectedTranslation: 0. translations := nil. self changed: #translations. ! ----- Method: LanguageEditor>>refreshUntranslated (in category 'updating') ----- refreshUntranslated "refresh the untranslated panel" self refreshTranslations. self selectedUntranslated: 0. untranslated := nil. self changed: #untranslated. ! ----- Method: LanguageEditor>>removeTranslatedButUnusedStrings (in category 'stef') ----- removeTranslatedButUnusedStrings (self confirm: 'Are you sure that you want to remove unused strings?' translated) ifFalse: [^ self]. translationsList getList do: [:each | | timesUsed | timesUsed := self numberOfTimesStringIsUsed: each. Transcript show: each. Transcript show: timesUsed printString; cr. timesUsed isZero ifTrue: [self translator removeTranslationFor: each]]! ----- Method: LanguageEditor>>removeTranslation (in category 'gui methods') ----- removeTranslation "remove the selected translation" | translation | self selectedTranslation isZero ifTrue: ["" self beep. self inform: 'select the translation to remove' translated. ^ self]. "" translation := self translations at: self selectedTranslation. "" (self confirm: ('Removing "{1}". Are you sure you want to do this?' translated format: {translation})) ifFalse: [^ self]. "" self translator removeTranslationFor: translation. self refreshBoth! ----- Method: LanguageEditor>>removeUntranslated (in category 'gui methods') ----- removeUntranslated "remove the selected untranslated phrase" | untrans | self selectedUntranslated isZero ifTrue: ["" self beep. self inform: 'select the untranslated phrase to remove' translated. ^ self]. "" untrans := self untranslated at: self selectedUntranslated. "" (self confirm: ('Removing "{1}". Are you sure you want to do this?' translated format: {untrans})) ifFalse: [^ self]. "" self translator removeUntranslated: untrans! ----- Method: LanguageEditor>>removeUntranslatedButUnusedStrings (in category 'stef') ----- removeUntranslatedButUnusedStrings (self confirm: 'Are you sure that you want to remove unused strings?' translated) ifFalse: [^ self]. untranslatedList getList do: [:each | | timesUsed | timesUsed := self numberOfTimesStringIsUsed: each. Transcript show: each. Transcript show: timesUsed printString; cr. timesUsed isZero ifTrue: [self translator removeUntranslated: each]]. self refreshUntranslated. ! ----- Method: LanguageEditor>>report (in category 'gui methods') ----- report self reportString openInWorkspaceWithTitle: 'report' translated! ----- Method: LanguageEditor>>reportString (in category 'reporting') ----- reportString "answer a string with a report of the receiver" | stream | stream := String new writeStream. self printReportOn: stream. ^ stream contents! ----- Method: LanguageEditor>>resetNewerKeys (in category 'gui methods') ----- resetNewerKeys self initializeNewerKeys. ! ----- Method: LanguageEditor>>saveToFile (in category 'gui methods') ----- saveToFile "save the translator to a file" | fileName | fileName := UIManager default request: 'file name' translated initialAnswer: translator localeID isoString , '.translation'. (fileName isNil or: [fileName isEmpty]) ifTrue: [ self beep. ^ self]. Cursor wait showWhile: [ self translator saveToFileNamed: fileName]! ----- Method: LanguageEditor>>searchTranslation (in category 'gui methods') ----- searchTranslation | search | search := UIManager default request: 'search for' translated initialAnswer: ''. (search isNil or: [search isEmpty]) ifTrue: [ self beep. ^ self]. self searchTranslation: search! ----- Method: LanguageEditor>>searchTranslation: (in category 'gui methods') ----- searchTranslation: aString | results index | results := self translations select: [:each | "" ('*' , aString , '*' match: each) or: ['*' , aString , '*' match: (self translator translate: each)]]. "" results isEmpty ifTrue: ["" self inform: 'no matches for' translated , ' ''' , aString , ''''. ^ self]. "" results size = 1 ifTrue: ["" self selectTranslationPhrase: results first. ^ self]. "" index := (PopUpMenu labelArray: (results collect: [:each | "" (each copy replaceAll: Character cr with: $\) , ' -> ' , ((self translator translate: each) copy replaceAll: Character cr with: $\)])) startUpWithCaption: 'select the translation...' translated. "" index isZero ifTrue: ["" self beep. ^ self]. "" self selectTranslationPhrase: (results at: index)! ----- Method: LanguageEditor>>searchUntranslated (in category 'gui methods') ----- searchUntranslated | search | search := UIManager default request: 'search for' translated initialAnswer: ''. (search isNil or: [search isEmpty]) ifTrue: [ self beep. ^ self]. self searchUntranslated: search! ----- Method: LanguageEditor>>searchUntranslated: (in category 'gui methods') ----- searchUntranslated: aString | untranslateds results index | untranslateds := self untranslated. results := untranslateds select: [:each | '*' , aString , '*' match: each]. "" results isEmpty ifTrue: ["" self inform: 'no matches for' translated , ' ''' , aString , ''''. ^ self]. "" results size = 1 ifTrue: ["" self selectUntranslatedPhrase: results first. ^ self]. "" index := (PopUpMenu labelArray: (results collect: [:each | each copy replaceAll: Character cr with: $\])) startUpWithCaption: 'select the untranslated phrase...' translated. "" index isZero ifTrue: ["" self beep. ^ self]. "" self selectUntranslatedPhrase: (results at: index)! ----- Method: LanguageEditor>>selectAllTranslation (in category 'gui methods') ----- selectAllTranslation selectedTranslations := (1 to: self translations size) asIdentitySet. self changed: #allSelections! ----- Method: LanguageEditor>>selectNewerKeys (in category 'gui methods') ----- selectNewerKeys | index | self deselectAllTranslation. newerKeys do: [:k | index := self translations indexOf: k ifAbsent: [0]. index > 0 ifTrue: [ self selectedTranslationsAt: index put: true ]. ]. ! ----- Method: LanguageEditor>>selectTranslationFileName (in category 'gui methods') ----- selectTranslationFileName "answer a file with a translation" | file | file := (StandardFileMenu oldFileMenu: FileDirectory default withPattern: '*.translation') startUpWithCaption: 'Select the file...' translated. ^ file isNil ifFalse: [file directory fullNameFor: file name]! ----- Method: LanguageEditor>>selectTranslationPhrase: (in category 'gui methods') ----- selectTranslationPhrase: phraseString self selectedTranslation: (self translations indexOf: phraseString)! ----- Method: LanguageEditor>>selectUntranslatedPhrase: (in category 'gui methods') ----- selectUntranslatedPhrase: phraseString self selectedUntranslated: (self untranslated indexOf: phraseString)! ----- Method: LanguageEditor>>selectedTranslation (in category 'accessing') ----- selectedTranslation "answer the selectedTranslation" ^ selectedTranslation! ----- Method: LanguageEditor>>selectedTranslation: (in category 'accessing') ----- selectedTranslation: anInteger "change the receiver's selectedTranslation" selectedTranslation := anInteger. "" self changed: #selectedTranslation. self changed: #translation! ----- Method: LanguageEditor>>selectedTranslationsAt: (in category 'accessing') ----- selectedTranslationsAt: index ^ selectedTranslations includes: index! ----- Method: LanguageEditor>>selectedTranslationsAt:put: (in category 'accessing') ----- selectedTranslationsAt: index put: value value = true ifTrue: [selectedTranslations add: index] ifFalse: [selectedTranslations remove: index ifAbsent: []]! ----- Method: LanguageEditor>>selectedUntranslated (in category 'accessing') ----- selectedUntranslated "answer the selectedUntranslated" ^ selectedUntranslated! ----- Method: LanguageEditor>>selectedUntranslated: (in category 'accessing') ----- selectedUntranslated: anInteger "change the selectedUntranslated" selectedUntranslated := anInteger. "" self changed: #selectedUntranslated! ----- Method: LanguageEditor>>status (in category 'gui methods') ----- status "answer a status string" | translationsSize untranslatedSize | translationsSize := self translator translations size. untranslatedSize := self translator untranslated size. ^ '| {1} phrases | {2} translated | {3} untranslated |' translated format: {translationsSize + untranslatedSize. translationsSize. untranslatedSize}! ----- Method: LanguageEditor>>translate (in category 'gui methods') ----- translate "translate a phrase" | phrase | phrase := self phraseToTranslate. "" (phrase isNil or: [phrase = '']) ifTrue: ["" self beep. ^ self]. "" self translatePhrase: phrase. self refreshBoth! ----- Method: LanguageEditor>>translatePhrase: (in category 'gui methods') ----- translatePhrase: aString "translate aString" | translation | translation := UIManager default multiLineRequest: 'translation for: ' translated , '''' , aString , '''' centerAt: Sensor cursorPoint initialAnswer: aString answerHeight: 200. (translation isNil or: [translation = '']) ifTrue: ["" self beep. ^ self]. self phrase: aString translation: translation! ----- Method: LanguageEditor>>translation (in category 'accessing') ----- translation "answer the translation for the selected phrase" self selectedTranslation isZero ifTrue: [^ '<select a phrase from the upper list>' translated]. "" ^ self translator translate: (self translations at: self selectedTranslation)! ----- Method: LanguageEditor>>translation: (in category 'accessing') ----- translation: aStringOrText "change the translation for the selected phrase" | phrase | self selectedTranslation isZero ifTrue: [^ self]. phrase := self translations at: self selectedTranslation. translator phrase: phrase translation: aStringOrText asString. newerKeys add: phrase. ^ true! ----- Method: LanguageEditor>>translations (in category 'accessing') ----- translations "answet the translator's translations" | allTranslations filterString | translations ifNotNil: [^translations]. allTranslations := self translator translations keys. "" filterString := self translationsFilter. "" filterString isEmpty ifFalse: [allTranslations := allTranslations select: [:each | "" ('*' , filterString , '*' match: each) or: ['*' , filterString , '*' match: (self translator translate: each)]]]. "" ^ translations := allTranslations asSortedCollection asArray! ----- Method: LanguageEditor>>translationsFilter (in category 'accessing') ----- translationsFilter ^translationsFilter ifNil:['']! ----- Method: LanguageEditor>>translationsFilterWording (in category 'gui methods') ----- translationsFilterWording ^ (self translationsFilter isEmpty ifTrue: ['filter' translated] ifFalse: ['filtering: {1}' translated format:{self translationsFilter}]) ! ----- Method: LanguageEditor>>translationsKeystroke: (in category 'gui methods') ----- translationsKeystroke: aChar "Respond to a Command key in the translations list." aChar == $x ifTrue: [^ self removeTranslation]. aChar == $E ifTrue: [^ self browseMethodsWithTranslation]! ----- Method: LanguageEditor>>translationsMenu: (in category 'gui methods') ----- translationsMenu: aMenu ^ aMenu add: 'remove (x)' translated action: #removeTranslation; add: 'where (E)' translated action: #browseMethodsWithTranslation; add: 'select all' translated action: #selectAllTranslation; add: 'deselect all' translated action: #deselectAllTranslation; add: 'select changed keys' translated action: #selectNewerKeys; add: 'export selection' translated action: #codeSelectedTranslation; add: 'export selection in do-it form' translated action: #codeSelectedTranslationAsMimeString; add: 'reset changed keys' translated action: #resetNewerKeys; yourself! ----- Method: LanguageEditor>>translator (in category 'private') ----- translator ^translator! ----- Method: LanguageEditor>>untranslated (in category 'accessing') ----- untranslated "answer the translator's untranslated phrases" | all filterString | untranslated ifNotNil: [^ untranslated]. all := self translator untranslated. "" filterString := self untranslatedFilter. "" filterString isEmpty ifFalse: [all := all select: [:each | "" ('*' , filterString , '*' match: each) or: ['*' , filterString , '*' match: (self translator translate: each)]]]. "" ^ untranslated := all asSortedCollection asArray! ----- Method: LanguageEditor>>untranslatedFilter (in category 'accessing') ----- untranslatedFilter ^ untranslatedFilter ifNil: ['']! ----- Method: LanguageEditor>>untranslatedFilterWording (in category 'gui methods') ----- untranslatedFilterWording ^ self untranslatedFilter isEmpty ifTrue: ['filter' translated] ifFalse: ['filtering: {1}' translated format: {self untranslatedFilter}]! ----- Method: LanguageEditor>>untranslatedKeystroke: (in category 'gui methods') ----- untranslatedKeystroke: aChar "Respond to a Command key in the translations list." aChar == $t ifTrue: [^ self translate]. aChar == $E ifTrue: [^ self browseMethodsWithUntranslated]! ----- Method: LanguageEditor>>untranslatedMenu: (in category 'gui methods') ----- untranslatedMenu: aMenu ^ aMenu add: 'remove' translated action: #removeUntranslated; add: 'translate (t)' translated action: #translate; add: 'where (E)' translated action: #browseMethodsWithUntranslated; yourself! ----- Method: LanguageEditor>>update: (in category 'updating') ----- update: aSymbol "Receive a change notice from an object of whom the receiver is a dependent." super update: aSymbol. "" aSymbol == #untranslated ifTrue: [self refreshUntranslated]. aSymbol == #translations ifTrue: [self refreshTranslations]! ----- Method: LanguageEditor>>withUnboundModelDo: (in category 'private') ----- withUnboundModelDo: aBlock "Private - Evaluate aBlock with the receiver temporary unbound from the model. Useful to perform a batch of modifications to the model without updating the view." | formerModel | formerModel := self model. self model: nil. [aBlock value: formerModel] ensure: [self model: formerModel]!

1 0

Squeak 4.6: ToolBuilder-Kernel-mt.89.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of ToolBuilder-Kernel to project Squeak 4.6: http://source.squeak.org/squeak46/ToolBuilder-Kernel-mt.89.mcz ==================== Summary ==================== Name: ToolBuilder-Kernel-mt.89 Author: mt Time: 12 May 2015, 9:02:56.628 pm UUID: 5175a13e-cae3-8f48-bd99-8a7d0d012866 Ancestors: ToolBuilder-Kernel-mt.88 Allow input fields to provide soft-line-wrap. ==================== Snapshot ==================== SystemOrganization addCategory: #'ToolBuilder-Kernel'! Notification subclass: #ProgressInitiationException instanceVariableNames: 'workBlock maxVal minVal aPoint progressTitle' classVariableNames: 'PreferredProgressBarPosition' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !ProgressInitiationException commentStamp: '<historical>' prior: 0! I provide a way to alter the behavior of the old-style progress notifier in String. See examples in: ProgressInitiationException testWithout. ProgressInitiationException testWith. ! ----- Method: ProgressInitiationException class>>display:at:from:to:during: (in category 'signalling') ----- display: aString at: aPoint from: minVal to: maxVal during: workBlock ^ self new display: aString at: (aPoint ifNil: [ self preferredProgressBarPoint ]) from: minVal to: maxVal during: workBlock! ----- Method: ProgressInitiationException class>>display:from:to:during: (in category 'signalling') ----- display: aString from: minVal to: maxVal during: workBlock ^ self display: aString at: nil from: minVal to: maxVal during: workBlock! ----- Method: ProgressInitiationException class>>preferredProgressBarPoint (in category 'accessing') ----- preferredProgressBarPoint ^ self preferredProgressBarPosition = #cursorPoint ifTrue: [ Sensor cursorPoint ] ifFalse: [ UIManager default screenBounds perform: self preferredProgressBarPosition ]! ----- Method: ProgressInitiationException class>>preferredProgressBarPosition (in category 'accessing') ----- preferredProgressBarPosition ^ PreferredProgressBarPosition ifNil: [ #center ]! ----- Method: ProgressInitiationException class>>preferredProgressBarPosition: (in category 'accessing') ----- preferredProgressBarPosition: aSymbol "Specify any of: #center, #topCenter, #bottomCenter, #leftCenter, #rightCenter, #topLeft, #topRight, #bottomLeft or #bottomRight or #cursorPoint." ^ PreferredProgressBarPosition! ----- Method: ProgressInitiationException class>>testInnermost (in category 'examples and tests') ----- testInnermost "test the progress code WITHOUT special handling" ^'Now here''s some Real Progress' displayProgressFrom: 0 to: 10 during: [ :bar | 1 to: 10 do: [ :x | bar value: x. (Delay forMilliseconds: 500) wait. x = 5 ifTrue: [1/0]. "just to make life interesting" ]. 'done' ]. ! ----- Method: ProgressInitiationException class>>testWith (in category 'examples and tests') ----- testWith "test progress code WITH special handling of progress notifications" ^[ self testWithAdditionalInfo ] on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | Transcript show: min printString,' ',max printString,' ',curr printString; cr ]. ]. ! ----- Method: ProgressInitiationException class>>testWithAdditionalInfo (in category 'examples and tests') ----- testWithAdditionalInfo ^{'starting'. self testWithout. 'really!!'}! ----- Method: ProgressInitiationException class>>testWithout (in category 'examples and tests') ----- testWithout "test the progress code WITHOUT special handling" ^[self testInnermost] on: ZeroDivide do: [ :ex | ex resume] ! ----- Method: ProgressInitiationException>>defaultAction (in category 'handling') ----- defaultAction self resume! ----- Method: ProgressInitiationException>>defaultResumeValue (in category 'handling') ----- defaultResumeValue ^ UIManager default displayProgress: progressTitle at: aPoint from: minVal to: maxVal during: workBlock! ----- Method: ProgressInitiationException>>display:at:from:to:during: (in category 'initialize-release') ----- display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock progressTitle := argString. aPoint := argPoint. minVal := argMinVal. maxVal := argMaxVal. workBlock := argWorkBlock. ^self signal! ----- Method: ProgressInitiationException>>sendNotificationsTo: (in category 'initialize-release') ----- sendNotificationsTo: aNewBlock self resume: ( workBlock value: [ :barVal | aNewBlock value: minVal value: maxVal value: barVal ] ) ! ----- Method: String>>displayProgressAt:from:to:during: (in category '*toolbuilder-kernel') ----- displayProgressAt: aPoint from: minVal to: maxVal during: workBlock "Display this string as a caption over a progress bar while workBlock is evaluated. EXAMPLE (Select next 6 lines and Do It) 'Now here''s some Real Progress' displayProgressAt: Sensor cursorPoint from: 0 to: 10 during: [:bar | 1 to: 10 do: [:x | bar value: x. (Delay forMilliseconds: 500) wait]]. HOW IT WORKS (Try this in any other language :-) Since your code (the last 2 lines in the above example) is in a block, this method gets control to display its heading before, and clean up the screen after, its execution. The key, though, is that the block is supplied with an argument, named 'bar' in the example, which will update the bar image every it is sent the message value: x, where x is in the from:to: range. " ^ProgressInitiationException display: self at: aPoint from: minVal to: maxVal during: workBlock! ----- Method: String>>displayProgressFrom:to:during: (in category '*toolbuilder-kernel') ----- displayProgressFrom: minVal to: maxVal during: workBlock "Display this string as a caption over a progress bar while workBlock is evaluated. EXAMPLE (Select next 6 lines and Do It) 'Now here''s some Real Progress' displayProgressFrom: 0 to: 10 during: [:bar | 1 to: 10 do: [:x | bar value: x. (Delay forMilliseconds: 500) wait]]." ^ self displayProgressAt: nil from: minVal to: maxVal during: workBlock! ----- Method: Object>>confirm: (in category '*ToolBuilder-Kernel-error handling') ----- confirm: queryString "Put up a yes/no menu with caption queryString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." "nil confirm: 'Are you hungry?'" ^ UIManager default confirm: queryString! ----- Method: Object>>confirm:orCancel: (in category '*ToolBuilder-Kernel-error handling') ----- confirm: aString orCancel: cancelBlock "Put up a yes/no/cancel menu with caption aString. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." ^ UIManager default confirm: aString orCancel: cancelBlock! ----- Method: Object>>inform: (in category '*ToolBuilder-Kernel-user interface') ----- inform: aString "Display a message for the user to read and then dismiss. 6/9/96 sw" aString isEmptyOrNil ifFalse: [UIManager default inform: aString]! Object subclass: #ToolBuilder instanceVariableNames: 'parent' classVariableNames: 'OpenToolsAttachedToMouseCursor' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !ToolBuilder commentStamp: '<historical>' prior: 0! I am a tool builder, that is an object which knows how to create concrete widgets from abstract specifications. Those specifications are used by tools which want to be able to function in diverse user interface paradigms, such as MVC, Morphic, Tweak, wxWidgets etc. The following five specs must be supported by all implementations: * PluggableButton * PluggableList * PluggableText * PluggablePanel * PluggableWindow The following specs are optional: * PluggableTree: If not supported, the tool builder must answer nil when asked for a pluggableTreeSpec. Substitution will require client support so clients must be aware that some tool builders may not support trees (MVC for example, or Seaside). See examples in FileListPlus or TestRunnerPlus. * PluggableMultiSelectionList: If multi-selection lists are not supported, tool builder will silently support regular single selection lists. * PluggableInputField: Intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText. * PluggableActionButton: Intended as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton. * PluggableRadioButton: Intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton. * PluggableCheckBox: Intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton. ! ----- Method: ToolBuilder class>>build: (in category 'instance creation') ----- build: aClass ^self default build: aClass! ----- Method: ToolBuilder class>>default (in category 'accessing') ----- default "Answer the default tool builder" ^ Project current uiManager toolBuilder ! ----- Method: ToolBuilder class>>findDefault (in category 'accessing') ----- findDefault "Answer a default tool builder" | builderClass | "Note: The way the following is phrased ensures that you can always make 'more specific' builders merely by subclassing a tool builder and implementing a more specific way of reacting to #isActiveBuilder. For example, a BobsUIToolBuilder can subclass MorphicToolBuilder and (if enabled, say Preferences useBobsUITools) will be considered before the parent (generic MorphicToolBuilder)." builderClass := self allSubclasses detect:[:any| any isActiveBuilder and:[ any subclasses noneSatisfy:[:sub| sub isActiveBuilder]]] ifNone:[nil]. builderClass ifNotNil: [^builderClass ]. ^self error: 'ToolBuilder not found'! ----- Method: ToolBuilder class>>isActiveBuilder (in category 'accessing') ----- isActiveBuilder "Answer whether I am the currently active builder" ^false! ----- Method: ToolBuilder class>>open: (in category 'instance creation') ----- open: aClass ^self default open: aClass! ----- Method: ToolBuilder class>>open:label: (in category 'instance creation') ----- open: aClass label: aString ^self default open: aClass label: aString! ----- Method: ToolBuilder class>>openToolsAttachedToMouseCursor (in category 'preferences') ----- openToolsAttachedToMouseCursor <preference: 'Open Tools Attached to Mouse Cursor' categoryList: #(Tools mouse) description: 'If enabled, new tool windows will be attached to the mouse cursor to be positioned on screen with an additional click. Only, if a mouse event triggered that tool.' type: #Boolean> ^ OpenToolsAttachedToMouseCursor ifNil: [false]! ----- Method: ToolBuilder class>>openToolsAttachedToMouseCursor: (in category 'preferences') ----- openToolsAttachedToMouseCursor: aBoolean OpenToolsAttachedToMouseCursor := aBoolean.! ----- Method: ToolBuilder>>build: (in category 'building') ----- build: anObject "Build the given object using this tool builder" ^anObject buildWith: self! ----- Method: ToolBuilder>>buildAll:in: (in category 'building') ----- buildAll: aList in: newParent "Build the given set of widgets in the new parent" | prior | aList ifNil:[^self]. prior := parent. parent := newParent. aList do:[:each| each buildWith: self]. parent := prior. ! ----- Method: ToolBuilder>>buildPluggableActionButton: (in category 'widgets optional') ----- buildPluggableActionButton: spec ^self buildPluggableButton: spec! ----- Method: ToolBuilder>>buildPluggableAlternateMultiSelectionList: (in category 'widgets optional') ----- buildPluggableAlternateMultiSelectionList: aSpec ^ self buildPluggableList: aSpec! ----- Method: ToolBuilder>>buildPluggableButton: (in category 'widgets required') ----- buildPluggableButton: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableCheckBox: (in category 'widgets optional') ----- buildPluggableCheckBox: spec ^self buildPluggableButton: spec! ----- Method: ToolBuilder>>buildPluggableCodePane: (in category 'widgets optional') ----- buildPluggableCodePane: aSpec ^self buildPluggableText: aSpec! ----- Method: ToolBuilder>>buildPluggableDropDownList: (in category 'widgets optional') ----- buildPluggableDropDownList: spec ^self buildPluggableList: spec! ----- Method: ToolBuilder>>buildPluggableInputField: (in category 'widgets optional') ----- buildPluggableInputField: aSpec ^self buildPluggableText: aSpec! ----- Method: ToolBuilder>>buildPluggableList: (in category 'widgets required') ----- buildPluggableList: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableMenu: (in category 'widgets required') ----- buildPluggableMenu: menuSpec self subclassResponsibility.! ----- Method: ToolBuilder>>buildPluggableMenuItem: (in category 'widgets required') ----- buildPluggableMenuItem: menuSpec self subclassResponsibility.! ----- Method: ToolBuilder>>buildPluggableMultiSelectionList: (in category 'widgets optional') ----- buildPluggableMultiSelectionList: aSpec ^self buildPluggableList: aSpec! ----- Method: ToolBuilder>>buildPluggablePanel: (in category 'widgets required') ----- buildPluggablePanel: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableRadioButton: (in category 'widgets optional') ----- buildPluggableRadioButton: spec ^self buildPluggableButton: spec! ----- Method: ToolBuilder>>buildPluggableScrollPane: (in category 'widgets optional') ----- buildPluggableScrollPane: spec ^ spec children ifNotNil: [self buildPluggablePanel: spec] ifNil: [spec morph ifNil: [spec morphClass new]]! ----- Method: ToolBuilder>>buildPluggableSpacer: (in category 'widgets required') ----- buildPluggableSpacer: aSpec ^ self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableText: (in category 'widgets required') ----- buildPluggableText: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableTree: (in category 'widgets required') ----- buildPluggableTree: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableWindow: (in category 'widgets required') ----- buildPluggableWindow: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>close: (in category 'opening') ----- close: aWidget "Close a previously opened widget" ^self subclassResponsibility! ----- Method: ToolBuilder>>initialize (in category 'initialize') ----- initialize ! ----- Method: ToolBuilder>>open: (in category 'opening') ----- open: anObject "Build and open the object. Answer the widget opened." ^self subclassResponsibility! ----- Method: ToolBuilder>>open:label: (in category 'opening') ----- open: anObject label: aString "Build an open the object, labeling it appropriately. Answer the widget opened." ^self subclassResponsibility! ----- Method: ToolBuilder>>openDebugger: (in category 'opening') ----- openDebugger: aSpec "Build and open a debugger from the given spec. Answer the widget opened. Subclasses can override this method if opening a debugger has specific requirements different from opening other widgets." self open: aSpec ! ----- Method: ToolBuilder>>openDebugger:label: (in category 'opening') ----- openDebugger: aSpec label: aString "Build and open a debugger from the given spec, labeling it appropriately. Answer the widget opened. Subclasses can override this method if opening a debugger has specific requirements different from opening other widgets." ^self open: aSpec label: aString ! ----- Method: ToolBuilder>>openDebugger:label:closing: (in category 'opening') ----- openDebugger: aSpec label: aString closing: topView "Build and open a debugger from the given spec, labeling it appropriately. Answer the widget opened. Subclasses can override this method if opening a debugger has specific requirements different from opening other widgets." self close: topView. self open: aSpec label: aString ! ----- Method: ToolBuilder>>parent (in category 'accessing') ----- parent ^parent! ----- Method: ToolBuilder>>parent: (in category 'accessing') ----- parent: aWidget parent := aWidget! ----- Method: ToolBuilder>>pluggableActionButtonSpec (in category 'defaults') ----- pluggableActionButtonSpec ^PluggableActionButtonSpec! ----- Method: ToolBuilder>>pluggableAlternateMultiSelectionListSpec (in category 'defaults') ----- pluggableAlternateMultiSelectionListSpec ^ PluggableAlternateMultiSelectionListSpec! ----- Method: ToolBuilder>>pluggableButtonSpec (in category 'defaults') ----- pluggableButtonSpec ^PluggableButtonSpec! ----- Method: ToolBuilder>>pluggableCheckBoxSpec (in category 'defaults') ----- pluggableCheckBoxSpec ^PluggableCheckBoxSpec! ----- Method: ToolBuilder>>pluggableCodePaneSpec (in category 'defaults') ----- pluggableCodePaneSpec ^PluggableCodePaneSpec! ----- Method: ToolBuilder>>pluggableDropDownListSpec (in category 'defaults') ----- pluggableDropDownListSpec ^PluggableDropDownListSpec! ----- Method: ToolBuilder>>pluggableInputFieldSpec (in category 'defaults') ----- pluggableInputFieldSpec ^PluggableInputFieldSpec! ----- Method: ToolBuilder>>pluggableListSpec (in category 'defaults') ----- pluggableListSpec ^PluggableListSpec! ----- Method: ToolBuilder>>pluggableMenuSpec (in category 'defaults') ----- pluggableMenuSpec ^ PluggableMenuSpec! ----- Method: ToolBuilder>>pluggableMultiSelectionListSpec (in category 'defaults') ----- pluggableMultiSelectionListSpec ^PluggableMultiSelectionListSpec! ----- Method: ToolBuilder>>pluggablePanelSpec (in category 'defaults') ----- pluggablePanelSpec ^PluggablePanelSpec! ----- Method: ToolBuilder>>pluggableRadioButtonSpec (in category 'defaults') ----- pluggableRadioButtonSpec ^PluggableRadioButtonSpec! ----- Method: ToolBuilder>>pluggableScrollPaneSpec (in category 'defaults') ----- pluggableScrollPaneSpec ^ PluggableScrollPaneSpec! ----- Method: ToolBuilder>>pluggableSpacerSpec (in category 'defaults') ----- pluggableSpacerSpec ^ PluggableSpacerSpec! ----- Method: ToolBuilder>>pluggableTextSpec (in category 'defaults') ----- pluggableTextSpec ^PluggableTextSpec! ----- Method: ToolBuilder>>pluggableTreeSpec (in category 'defaults') ----- pluggableTreeSpec ^PluggableTreeSpec! ----- Method: ToolBuilder>>pluggableWindowSpec (in category 'defaults') ----- pluggableWindowSpec ^PluggableWindowSpec! ----- Method: ToolBuilder>>runModal: (in category 'opening') ----- runModal: aWidget "Run the (previously opened) widget modally, e.g., do not return control to the sender before the user has responded." ^self subclassResponsibility! ----- Method: ToolBuilder>>widgetAt: (in category 'accessing') ----- widgetAt: widgetID "Answer the widget with the given ID" ^self widgetAt: widgetID ifAbsent:[nil]! ----- Method: ToolBuilder>>widgetAt:ifAbsent: (in category 'accessing') ----- widgetAt: widgetID ifAbsent: aBlock "Answer the widget with the given ID" ^aBlock value! Object subclass: #ToolBuilderSpec instanceVariableNames: 'name help' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !ToolBuilderSpec commentStamp: 'ar 2/11/2005 14:59' prior: 0! I am an abstract widget specification. I can be rendered using many different UI frameworks.! ToolBuilderSpec subclass: #PluggableMenuItemSpec instanceVariableNames: 'label action checked enabled separator subMenu checkable' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableMenuItemSpec>>action (in category 'accessing') ----- action "Answer the action associated with the receiver" ^action! ----- Method: PluggableMenuItemSpec>>action: (in category 'accessing') ----- action: aMessageSend "Answer the action associated with the receiver" action := aMessageSend! ----- Method: PluggableMenuItemSpec>>analyzeLabel (in category 'initialize') ----- analyzeLabel "For Morphic compatiblity. Some labels include markup such as <on>, <off> etc. Analyze the label for these annotations and take appropriate action." | marker | marker := label copyFrom: 1 to: (label indexOf: $>). (marker = '<on>' or:[marker = '<yes>']) ifTrue:[ checkable := true. checked := true. label := label copyFrom: marker size+1 to: label size. ]. (marker = '<off>' or:[marker = '<no>']) ifTrue:[ checkable := true. checked := false. label := label copyFrom: marker size+1 to: label size. ]. ! ----- Method: PluggableMenuItemSpec>>beCheckable (in category 'accessing') ----- beCheckable checkable := true.! ----- Method: PluggableMenuItemSpec>>buildWith: (in category 'building') ----- buildWith: builder ^ builder buildPluggableMenuItem: self! ----- Method: PluggableMenuItemSpec>>checked (in category 'accessing') ----- checked "Answer whether the receiver is checked" ^checked ifNil:[false]! ----- Method: PluggableMenuItemSpec>>checked: (in category 'accessing') ----- checked: aBool "Indicate whether the receiver is checked" checked := aBool.! ----- Method: PluggableMenuItemSpec>>enabled (in category 'accessing') ----- enabled "Answer whether the receiver is enabled" ^enabled ifNil:[true]! ----- Method: PluggableMenuItemSpec>>enabled: (in category 'accessing') ----- enabled: aBool "Indicate whether the receiver is enabled" enabled := aBool! ----- Method: PluggableMenuItemSpec>>initialize (in category 'initialize') ----- initialize checkable := false.! ----- Method: PluggableMenuItemSpec>>isCheckable (in category 'accessing') ----- isCheckable ^ checkable! ----- Method: PluggableMenuItemSpec>>label (in category 'accessing') ----- label "Answer the receiver's label" ^label! ----- Method: PluggableMenuItemSpec>>label: (in category 'accessing') ----- label: aString "Set the receiver's label" label := aString! ----- Method: PluggableMenuItemSpec>>separator (in category 'accessing') ----- separator "Answer whether the receiver should be followed by a separator" ^separator ifNil:[false]! ----- Method: PluggableMenuItemSpec>>separator: (in category 'accessing') ----- separator: aBool "Indicate whether the receiver should be followed by a separator" separator := aBool.! ----- Method: PluggableMenuItemSpec>>subMenu (in category 'accessing') ----- subMenu "Answer the receiver's subMenu" ^subMenu! ----- Method: PluggableMenuItemSpec>>subMenu: (in category 'accessing') ----- subMenu: aMenuSpec "Answer the receiver's subMenu" subMenu := aMenuSpec! ToolBuilderSpec subclass: #PluggableMenuSpec instanceVariableNames: 'label model items' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableMenuSpec class>>withModel: (in category 'as yet unclassified') ----- withModel: aModel ^ self new model: aModel! ----- Method: PluggableMenuSpec>>add:action: (in category 'construction') ----- add: aString action: aMessageSend | item | item := self addMenuItem. item label: aString. item action: aMessageSend. ^item! ----- Method: PluggableMenuSpec>>add:target:selector:argumentList: (in category 'construction') ----- add: aString target: anObject selector: aSelector argumentList: anArray ^self add: aString action: (MessageSend receiver: anObject selector: aSelector arguments: anArray).! ----- Method: PluggableMenuSpec>>addList: (in category 'construction') ----- addList: aList "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help." aList do: [:tuple | (tuple == #-) ifTrue: [self addSeparator] ifFalse:[ | item | item := self add: tuple first target: model selector: tuple second argumentList: #(). tuple size > 2 ifTrue:[item help: tuple third]]]! ----- Method: PluggableMenuSpec>>addMenuItem (in category 'construction') ----- addMenuItem | item | item := self newMenuItem. self items add: item. ^item! ----- Method: PluggableMenuSpec>>addSeparator (in category 'construction') ----- addSeparator self items isEmpty ifTrue:[^nil]. self items last separator: true.! ----- Method: PluggableMenuSpec>>analyzeItemLabels (in category 'construction') ----- analyzeItemLabels "Analyze the item labels" items do:[:item| item analyzeLabel]. ! ----- Method: PluggableMenuSpec>>buildWith: (in category 'construction') ----- buildWith: builder self analyzeItemLabels. ^ builder buildPluggableMenu: self! ----- Method: PluggableMenuSpec>>items (in category 'accessing') ----- items ^ items ifNil: [items := OrderedCollection new]! ----- Method: PluggableMenuSpec>>label (in category 'accessing') ----- label ^label! ----- Method: PluggableMenuSpec>>label: (in category 'accessing') ----- label: aString label := aString.! ----- Method: PluggableMenuSpec>>model (in category 'accessing') ----- model ^ model! ----- Method: PluggableMenuSpec>>model: (in category 'accessing') ----- model: anObject model := anObject! ----- Method: PluggableMenuSpec>>newMenuItem (in category 'construction') ----- newMenuItem ^PluggableMenuItemSpec new! ToolBuilderSpec subclass: #PluggableWidgetSpec instanceVariableNames: 'model frame color minimumExtent margin padding horizontalResizing verticalResizing' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableWidgetSpec commentStamp: 'ar 2/9/2005 18:40' prior: 0! The abstract superclass for all widgets. Instance variables: model <Object> The object the various requests should be directed to. frame <Rectangle> The associated layout frame for this object (if any). ! PluggableWidgetSpec subclass: #PluggableButtonSpec instanceVariableNames: 'action label state enabled style changeLabelWhen' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableButtonSpec commentStamp: 'ar 2/11/2005 21:57' prior: 0! A button, both for firing as well as used in radio-button style (e.g., carrying a selection). Instance variables: action <Symbol> The action to perform when the button is fired. label <Symbol|String> The selector for retrieving the button's label or label directly. state <Symbol> The selector for retrieving the button's selection state. enabled <Symbo> The selector for retrieving the button's enabled state. color <Symbo> The selector for retrieving the button color. help <String> The balloon help for the button.! PluggableButtonSpec subclass: #PluggableActionButtonSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableActionButtonSpec commentStamp: 'dtl 9/19/2011 07:51' prior: 0! PluggableActionButtonSpec is intended as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton.! ----- Method: PluggableActionButtonSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableActionButton: self! ----- Method: PluggableButtonSpec>>action (in category 'accessing') ----- action "Answer the action to be performed by the receiver" ^action! ----- Method: PluggableButtonSpec>>action: (in category 'accessing') ----- action: aSymbol "Indicate the action to be performed by the receiver" action := aSymbol! ----- Method: PluggableButtonSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableButton: self! ----- Method: PluggableButtonSpec>>changeLabelWhen (in category 'accessing') ----- changeLabelWhen "When handled in in an update: handler, treat this symbol as notification that the button label should be updated." ^changeLabelWhen! ----- Method: PluggableButtonSpec>>changeLabelWhen: (in category 'accessing') ----- changeLabelWhen: aSymbol "When the button handles aSymbol in its update: handler, treat it as notification that the button label should be updated." changeLabelWhen := aSymbol! ----- Method: PluggableButtonSpec>>enabled (in category 'accessing') ----- enabled "Answer the selector for retrieving the button's enablement" ^enabled ifNil:[true]! ----- Method: PluggableButtonSpec>>enabled: (in category 'accessing') ----- enabled: aSymbol "Indicate the selector for retrieving the button's enablement" enabled := aSymbol! ----- Method: PluggableButtonSpec>>label (in category 'accessing') ----- label "Answer the label (or the selector for retrieving the label)" ^label! ----- Method: PluggableButtonSpec>>label: (in category 'accessing') ----- label: aSymbol "Indicate the selector for retrieving the label" label := aSymbol.! ----- Method: PluggableButtonSpec>>state (in category 'accessing') ----- state "Answer the selector for retrieving the button's state" ^state! ----- Method: PluggableButtonSpec>>state: (in category 'accessing') ----- state: aSymbol "Indicate the selector for retrieving the button's state" state := aSymbol.! ----- Method: PluggableButtonSpec>>style (in category 'accessing') ----- style "Treat aSymbol as a hint to modify the button appearance." ^style ! ----- Method: PluggableButtonSpec>>style: (in category 'accessing') ----- style: aSymbol "Use aSymbol as a hint to modify the button appearance." style := aSymbol ! PluggableButtonSpec subclass: #PluggableCheckBoxSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableCheckBoxSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0! PluggableCheckBox is intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton.! ----- Method: PluggableCheckBoxSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableCheckBox: self! PluggableButtonSpec subclass: #PluggableRadioButtonSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableRadioButtonSpec commentStamp: 'ar 2/12/2005 23:14' prior: 0! PluggableRadioButton is intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton.! ----- Method: PluggableRadioButtonSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableRadioButton: self! PluggableWidgetSpec subclass: #PluggableCompositeSpec instanceVariableNames: 'children layout wantsResizeHandles spacing' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableCompositeSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0! A composite user interface element. Instance variables: children <Symbol|Collection> Symbol to retrieve children or children directly layout <Symbol> The layout for this composite. ! ----- Method: PluggableCompositeSpec>>children (in category 'accessing') ----- children "Answer the selector to retrieve this panel's children" ^children! ----- Method: PluggableCompositeSpec>>children: (in category 'accessing') ----- children: aSymbol "Indicate the selector to retrieve this panel's children" children := aSymbol! ----- Method: PluggableCompositeSpec>>layout (in category 'accessing') ----- layout "Answer the symbol indicating the layout of the composite: #proportional (default): Use frames as appropriate. #horizontal: Arrange the elements horizontally #vertical: Arrange the elements vertically. " ^layout ifNil:[#proportional]! ----- Method: PluggableCompositeSpec>>layout: (in category 'accessing') ----- layout: aSymbol "Answer the symbol indicating the layout of the composite: #proportional (default): Use frames as appropriate. #horizontal: Arrange the elements horizontally #vertical: Arrange the elements vertically. " layout := aSymbol! ----- Method: PluggableCompositeSpec>>spacing (in category 'layout hints') ----- spacing "...between components of this widget." ^ spacing! ----- Method: PluggableCompositeSpec>>spacing: (in category 'layout hints') ----- spacing: numberOrPoint spacing := numberOrPoint.! ----- Method: PluggableCompositeSpec>>wantsResizeHandles (in category 'accessing') ----- wantsResizeHandles ^ wantsResizeHandles! ----- Method: PluggableCompositeSpec>>wantsResizeHandles: (in category 'accessing') ----- wantsResizeHandles: aBoolean wantsResizeHandles := aBoolean.! PluggableCompositeSpec subclass: #PluggablePanelSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggablePanelSpec commentStamp: 'ar 2/11/2005 15:01' prior: 0! A panel with a (possibly changing) set of child elements. Expects to see change/update notifications when the childrens change.! ----- Method: PluggablePanelSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggablePanel: self.! PluggableCompositeSpec subclass: #PluggableScrollPaneSpec instanceVariableNames: 'morph morphClass borderWidth vScrollBarPolicy hScrollBarPolicy' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableScrollPaneSpec>>borderWidth (in category 'accessing') ----- borderWidth ^ borderWidth ifNil: [1]! ----- Method: PluggableScrollPaneSpec>>borderWidth: (in category 'accessing') ----- borderWidth: anObject borderWidth := anObject! ----- Method: PluggableScrollPaneSpec>>buildWith: (in category 'building') ----- buildWith: builder ^ builder buildPluggableScrollPane: self! ----- Method: PluggableScrollPaneSpec>>hScrollBarPolicy (in category 'accessing') ----- hScrollBarPolicy ^ hScrollBarPolicy ifNil: [#always]! ----- Method: PluggableScrollPaneSpec>>hScrollBarPolicy: (in category 'accessing') ----- hScrollBarPolicy: anObject "#always, #never, #whenNeeded" hScrollBarPolicy := anObject! ----- Method: PluggableScrollPaneSpec>>morph (in category 'accessing') ----- morph ^ morph! ----- Method: PluggableScrollPaneSpec>>morph: (in category 'accessing') ----- morph: anObject morph := anObject! ----- Method: PluggableScrollPaneSpec>>morphClass (in category 'accessing') ----- morphClass ^ morphClass! ----- Method: PluggableScrollPaneSpec>>morphClass: (in category 'accessing') ----- morphClass: anObject morphClass := anObject! ----- Method: PluggableScrollPaneSpec>>vScrollBarPolicy (in category 'accessing') ----- vScrollBarPolicy ^ vScrollBarPolicy ifNil: [#always]! ----- Method: PluggableScrollPaneSpec>>vScrollBarPolicy: (in category 'accessing') ----- vScrollBarPolicy: anObject "#always, #never, #whenNeeded" vScrollBarPolicy := anObject! PluggableCompositeSpec subclass: #PluggableWindowSpec instanceVariableNames: 'label extent closeAction isDialog multiWindowStyle' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableWindowSpec commentStamp: '<historical>' prior: 0! A common window. Expects to see change/update notifications when the label should change. Instance variables: label <String|Symbol> The selector under which to retrieve the label or the label directly extent <Point> The (initial) extent of the window. closeAction <Symbol> The action to perform when the window is closed.! ----- Method: PluggableWindowSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableWindow: self.! ----- Method: PluggableWindowSpec>>closeAction (in category 'accessing') ----- closeAction "Answer the receiver's closeAction" ^closeAction! ----- Method: PluggableWindowSpec>>closeAction: (in category 'accessing') ----- closeAction: aSymbol "Answer the receiver's closeAction" closeAction := aSymbol.! ----- Method: PluggableWindowSpec>>extent (in category 'accessing') ----- extent "Answer the window's (initial) extent" ^extent! ----- Method: PluggableWindowSpec>>extent: (in category 'accessing') ----- extent: aPoint "Indicate the window's (initial) extent" extent := aPoint! ----- Method: PluggableWindowSpec>>isDialog (in category 'accessing') ----- isDialog ^isDialog ifNil: [false] ! ----- Method: PluggableWindowSpec>>isDialog: (in category 'accessing') ----- isDialog: val isDialog := val ! ----- Method: PluggableWindowSpec>>label (in category 'accessing') ----- label "Answer the selector for retrieving the window's label" ^label! ----- Method: PluggableWindowSpec>>label: (in category 'accessing') ----- label: aString "Indicate the selector for retrieving the window's label" label := aString! ----- Method: PluggableWindowSpec>>multiWindowStyle (in category 'accessing') ----- multiWindowStyle "Answer the value of multiWindowStyle, a Symbol or nil" ^multiWindowStyle! ----- Method: PluggableWindowSpec>>multiWindowStyle: (in category 'accessing') ----- multiWindowStyle: aSymbol "Set the value of multiWindowStyle, one of #labelButton or #tabbed" multiWindowStyle := aSymbol! PluggableWidgetSpec subclass: #PluggableDropDownListSpec instanceVariableNames: 'listSelector selectionSelector selectionSetter' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableDropDownListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableDropDownList: self! ----- Method: PluggableDropDownListSpec>>listSelector (in category 'accessing') ----- listSelector "Answer the value of listSelector" ^ listSelector! ----- Method: PluggableDropDownListSpec>>listSelector: (in category 'accessing') ----- listSelector: anObject "Set the value of listSelector" listSelector := anObject! ----- Method: PluggableDropDownListSpec>>selectionSelector (in category 'accessing') ----- selectionSelector "Answer the value of selectionSelector" ^ selectionSelector! ----- Method: PluggableDropDownListSpec>>selectionSelector: (in category 'accessing') ----- selectionSelector: anObject "Set the value of selectionSelector" selectionSelector := anObject! ----- Method: PluggableDropDownListSpec>>selectionSetter (in category 'accessing') ----- selectionSetter "Answer the value of selectionSetter" ^ selectionSetter! ----- Method: PluggableDropDownListSpec>>selectionSetter: (in category 'accessing') ----- selectionSetter: anObject "Set the value of selectionSetter" selectionSetter := anObject! PluggableWidgetSpec subclass: #PluggableListSpec instanceVariableNames: 'list getIndex setIndex getSelected setSelected menu keyPress autoDeselect dragItem dropItem dropAccept doubleClick listSize listItem keystrokePreview icon vScrollBarPolicy hScrollBarPolicy' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableListSpec commentStamp: 'ar 7/15/2005 11:54' prior: 0! A single selection list element. Instance variables: list <Symbol> The selector to retrieve the list elements. getIndex <Symbol> The selector to retrieve the list selection index. setIndex <Symbol> The selector to set the list selection index. getSelected <Symbol> The selector to retrieve the list selection. setSelected <Symbol> The selector to set the list selection. menu <Symbol> The selector to offer (to retrieve?) the context menu. keyPress <Symbol> The selector to invoke for handling keyboard shortcuts. autoDeselect <Boolean> Whether the list should allow automatic deselection or not. dragItem <Symbol> Selector to initiate a drag action on an item dropItem <Symbol> Selector to initiate a drop action of an item dropAccept <Symbol> Selector to determine whether a drop would be accepted! ----- Method: PluggableListSpec>>autoDeselect (in category 'accessing') ----- autoDeselect "Answer whether this tree can be automatically deselected" ^autoDeselect ifNil:[true]! ----- Method: PluggableListSpec>>autoDeselect: (in category 'accessing') ----- autoDeselect: aBool "Indicate whether this tree can be automatically deselected" autoDeselect := aBool! ----- Method: PluggableListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableList: self! ----- Method: PluggableListSpec>>doubleClick (in category 'accessing') ----- doubleClick "Answer the selector to perform when a double-click occurs" ^doubleClick! ----- Method: PluggableListSpec>>doubleClick: (in category 'accessing') ----- doubleClick: aSymbol "Set the selector to perform when a double-click occurs" doubleClick := aSymbol.! ----- Method: PluggableListSpec>>dragItem (in category 'accessing') ----- dragItem "Answer the selector for dragging an item" ^dragItem! ----- Method: PluggableListSpec>>dragItem: (in category 'accessing') ----- dragItem: aSymbol "Set the selector for dragging an item" dragItem := aSymbol! ----- Method: PluggableListSpec>>dropAccept (in category 'accessing') ----- dropAccept "Answer the selector to determine whether a drop would be accepted" ^dropAccept! ----- Method: PluggableListSpec>>dropAccept: (in category 'accessing') ----- dropAccept: aSymbol "Answer the selector to determine whether a drop would be accepted" dropAccept := aSymbol.! ----- Method: PluggableListSpec>>dropItem (in category 'accessing') ----- dropItem "Answer the selector for dropping an item" ^dropItem! ----- Method: PluggableListSpec>>dropItem: (in category 'accessing') ----- dropItem: aSymbol "Set the selector for dropping an item" dropItem := aSymbol! ----- Method: PluggableListSpec>>getIndex (in category 'accessing') ----- getIndex "Answer the selector for retrieving the list's selection index" ^getIndex! ----- Method: PluggableListSpec>>getIndex: (in category 'accessing') ----- getIndex: aSymbol "Indicate the selector for retrieving the list's selection index" getIndex := aSymbol! ----- Method: PluggableListSpec>>getSelected (in category 'accessing') ----- getSelected "Answer the selector for retrieving the list selection" ^getSelected! ----- Method: PluggableListSpec>>getSelected: (in category 'accessing') ----- getSelected: aSymbol "Indicate the selector for retrieving the list selection" getSelected := aSymbol! ----- Method: PluggableListSpec>>hScrollBarPolicy (in category 'accessing') ----- hScrollBarPolicy ^ hScrollBarPolicy! ----- Method: PluggableListSpec>>hScrollBarPolicy: (in category 'accessing') ----- hScrollBarPolicy: aSymbol "#always, #never, #whenNeeded" hScrollBarPolicy := aSymbol.! ----- Method: PluggableListSpec>>icon (in category 'accessing') ----- icon ^ icon! ----- Method: PluggableListSpec>>icon: (in category 'accessing') ----- icon: aSelector icon := aSelector! ----- Method: PluggableListSpec>>keyPress (in category 'accessing') ----- keyPress "Answer the selector for invoking the list's keyPress handler" ^keyPress! ----- Method: PluggableListSpec>>keyPress: (in category 'accessing') ----- keyPress: aSymbol "Indicate the selector for invoking the list's keyPress handler" keyPress := aSymbol! ----- Method: PluggableListSpec>>keystrokePreview (in category 'accessing') ----- keystrokePreview "Answer the selector to determine whether to allow the model a preview of keystrokes" ^ keystrokePreview! ----- Method: PluggableListSpec>>keystrokePreview: (in category 'accessing') ----- keystrokePreview: aSymbol "The selector to determine whether to allow the model a preview of keystrokes" keystrokePreview := aSymbol.! ----- Method: PluggableListSpec>>list (in category 'accessing') ----- list "Answer the selector for retrieving the list contents" ^list! ----- Method: PluggableListSpec>>list: (in category 'accessing') ----- list: aSymbol "Indicate the selector for retrieving the list contents" list := aSymbol.! ----- Method: PluggableListSpec>>listItem (in category 'accessing') ----- listItem "Answer the selector for retrieving the list element" ^listItem! ----- Method: PluggableListSpec>>listItem: (in category 'accessing') ----- listItem: aSymbol "Indicate the selector for retrieving the list element" listItem := aSymbol.! ----- Method: PluggableListSpec>>listSize (in category 'accessing') ----- listSize "Answer the selector for retrieving the list size" ^listSize! ----- Method: PluggableListSpec>>listSize: (in category 'accessing') ----- listSize: aSymbol "Indicate the selector for retrieving the list size" listSize := aSymbol.! ----- Method: PluggableListSpec>>menu (in category 'accessing') ----- menu "Answer the selector for retrieving the list's menu" ^menu! ----- Method: PluggableListSpec>>menu: (in category 'accessing') ----- menu: aSymbol "Indicate the selector for retrieving the list's menu" menu := aSymbol! ----- Method: PluggableListSpec>>setIndex (in category 'accessing') ----- setIndex "Answer the selector for setting the list's selection index" ^setIndex! ----- Method: PluggableListSpec>>setIndex: (in category 'accessing') ----- setIndex: aSymbol "Answer the selector for setting the list's selection index" setIndex := aSymbol! ----- Method: PluggableListSpec>>setSelected (in category 'accessing') ----- setSelected "Answer the selector for setting the list selection" ^setSelected! ----- Method: PluggableListSpec>>setSelected: (in category 'accessing') ----- setSelected: aSymbol "Indicate the selector for setting the list selection" setSelected := aSymbol! ----- Method: PluggableListSpec>>vScrollBarPolicy (in category 'accessing') ----- vScrollBarPolicy ^ vScrollBarPolicy! ----- Method: PluggableListSpec>>vScrollBarPolicy: (in category 'accessing') ----- vScrollBarPolicy: aSymbol "#always, #never, #whenNeeded" vScrollBarPolicy := aSymbol.! PluggableListSpec subclass: #PluggableMultiSelectionListSpec instanceVariableNames: 'getSelectionList setSelectionList' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableMultiSelectionListSpec commentStamp: 'ar 2/12/2005 13:31' prior: 0! PluggableMultiSelectionListSpec specifies a list with multiple selection behavior. Instance variables: getSelectionList <Symbol> The message to retrieve the multiple selections. setSelectionList <Symbol> The message to indicate multiple selections.! PluggableMultiSelectionListSpec subclass: #PluggableAlternateMultiSelectionListSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableAlternateMultiSelectionListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^ builder buildPluggableAlternateMultiSelectionList: self! ----- Method: PluggableMultiSelectionListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableMultiSelectionList: self! ----- Method: PluggableMultiSelectionListSpec>>getSelectionList (in category 'accessing') ----- getSelectionList "Answer the message to retrieve the multiple selections" ^getSelectionList! ----- Method: PluggableMultiSelectionListSpec>>getSelectionList: (in category 'accessing') ----- getSelectionList: aSymbol "Indicate the message to retrieve the multiple selections" getSelectionList := aSymbol! ----- Method: PluggableMultiSelectionListSpec>>setSelectionList (in category 'accessing') ----- setSelectionList "Answer the message to indicate multiple selections" ^setSelectionList! ----- Method: PluggableMultiSelectionListSpec>>setSelectionList: (in category 'accessing') ----- setSelectionList: aSymbol "Indicate the message to indicate multiple selections" setSelectionList := aSymbol! PluggableWidgetSpec subclass: #PluggableSpacerSpec instanceVariableNames: 'extent' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableSpacerSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableSpacer: self! ----- Method: PluggableSpacerSpec>>color (in category 'accessing') ----- color ^ super color ifNil: [Color transparent]! ----- Method: PluggableSpacerSpec>>extent (in category 'layout hints') ----- extent ^ extent ifNil: [5@5]! ----- Method: PluggableSpacerSpec>>extent: (in category 'layout hints') ----- extent: aPoint extent := aPoint.! ----- Method: PluggableSpacerSpec>>fillSpaceHorizontally (in category 'convenience') ----- fillSpaceHorizontally self horizontalResizing: #spaceFill.! ----- Method: PluggableSpacerSpec>>fillSpaceVertically (in category 'convenience') ----- fillSpaceVertically self verticalResizing: #spaceFill.! ----- Method: PluggableSpacerSpec>>horizontalResizing (in category 'accessing') ----- horizontalResizing ^ super horizontalResizing ifNil: [#rigid]! ----- Method: PluggableSpacerSpec>>verticalResizing (in category 'accessing') ----- verticalResizing ^ super verticalResizing ifNil: [#rigid]! PluggableWidgetSpec subclass: #PluggableTextSpec instanceVariableNames: 'getText setText selection menu askBeforeDiscardingEdits editText indicateUnacceptedChanges stylerClass font readOnly softLineWrap hardLineWrap' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableTextSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0! A text editor. Instance variables: getText <Symbol> The selector to retrieve the text. setText <Symbol> The selector to set the text. selection <Symbol> The selector to retrieve the text selection. menu <Symbol> The selector to offer (to retrieve?) the context menu. color <Symbol> The selector to retrieve the background color. ! PluggableTextSpec subclass: #PluggableCodePaneSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableCodePaneSpec commentStamp: 'ar 8/18/2009 00:02' prior: 0! A PluggableTextSpec specifically intended to edit code. Uses Syntax-Highlighting.! ----- Method: PluggableCodePaneSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableCodePane: self! ----- Method: PluggableCodePaneSpec>>font (in category 'accessing') ----- font ^ font ifNil: [Preferences standardCodeFont]! ----- Method: PluggableCodePaneSpec>>stylerClass (in category 'accessing') ----- stylerClass ^ super stylerClass ifNil: [Smalltalk classNamed: 'SHTextStylerST80']! PluggableTextSpec subclass: #PluggableInputFieldSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableInputFieldSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0! PluggableInputField is intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText.! ----- Method: PluggableInputFieldSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableInputField: self! ----- Method: PluggableInputFieldSpec>>hardLineWrap (in category 'accessing') ----- hardLineWrap ^ false! ----- Method: PluggableInputFieldSpec>>softLineWrap (in category 'accessing') ----- softLineWrap ^ super softLineWrap ifNil: [false]! ----- Method: PluggableTextSpec>>askBeforeDiscardingEdits (in category 'accessing') ----- askBeforeDiscardingEdits ^askBeforeDiscardingEdits ifNil:[true]! ----- Method: PluggableTextSpec>>askBeforeDiscardingEdits: (in category 'accessing') ----- askBeforeDiscardingEdits: aBool askBeforeDiscardingEdits := aBool! ----- Method: PluggableTextSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableText: self! ----- Method: PluggableTextSpec>>editText (in category 'accessing') ----- editText ^ editText! ----- Method: PluggableTextSpec>>editText: (in category 'accessing') ----- editText: aSymbol "Answer the selector for getting informed about any modifications of the text." editText := aSymbol! ----- Method: PluggableTextSpec>>font (in category 'accessing') ----- font ^ font ifNil: [Preferences standardDefaultTextFont]! ----- Method: PluggableTextSpec>>font: (in category 'accessing') ----- font: aFont font := aFont.! ----- Method: PluggableTextSpec>>getText (in category 'accessing') ----- getText "Answer the selector for retrieving the text" ^getText! ----- Method: PluggableTextSpec>>getText: (in category 'accessing') ----- getText: aSymbol "Answer the selector for retrieving the text" getText := aSymbol! ----- Method: PluggableTextSpec>>hardLineWrap (in category 'accessing') ----- hardLineWrap ^ hardLineWrap! ----- Method: PluggableTextSpec>>hardLineWrap: (in category 'accessing') ----- hardLineWrap: aBoolean hardLineWrap := aBoolean.! ----- Method: PluggableTextSpec>>indicateUnacceptedChanges (in category 'accessing') ----- indicateUnacceptedChanges ^ indicateUnacceptedChanges ifNil: [true]! ----- Method: PluggableTextSpec>>indicateUnacceptedChanges: (in category 'accessing') ----- indicateUnacceptedChanges: aBoolean indicateUnacceptedChanges := aBoolean.! ----- Method: PluggableTextSpec>>menu (in category 'accessing') ----- menu "Answer the selector for retrieving the text's menu" ^menu! ----- Method: PluggableTextSpec>>menu: (in category 'accessing') ----- menu: aSymbol "Indicate the selector for retrieving the text's menu" menu := aSymbol! ----- Method: PluggableTextSpec>>readOnly (in category 'accessing') ----- readOnly ^ readOnly ifNil: [false]! ----- Method: PluggableTextSpec>>readOnly: (in category 'accessing') ----- readOnly: aBoolean readOnly := aBoolean.! ----- Method: PluggableTextSpec>>selection (in category 'accessing') ----- selection "Answer the selector for retrieving the text selection" ^selection! ----- Method: PluggableTextSpec>>selection: (in category 'accessing') ----- selection: aSymbol "Indicate the selector for retrieving the text selection" selection := aSymbol! ----- Method: PluggableTextSpec>>setText (in category 'accessing') ----- setText "Answer the selector for setting the text" ^setText! ----- Method: PluggableTextSpec>>setText: (in category 'accessing') ----- setText: aSymbol "Answer the selector for setting the text" setText := aSymbol! ----- Method: PluggableTextSpec>>softLineWrap (in category 'accessing') ----- softLineWrap ^ softLineWrap! ----- Method: PluggableTextSpec>>softLineWrap: (in category 'accessing') ----- softLineWrap: aBoolean softLineWrap := aBoolean.! ----- Method: PluggableTextSpec>>stylerClass (in category 'accessing') ----- stylerClass ^ stylerClass! ----- Method: PluggableTextSpec>>stylerClass: (in category 'accessing') ----- stylerClass: aStylerClass stylerClass := aStylerClass.! PluggableWidgetSpec subclass: #PluggableTreeSpec instanceVariableNames: 'roots getSelectedPath setSelected getSelected setSelectedParent getChildren hasChildren label icon unusedVar menu keyPress wantsDrop dropItem dropAccept autoDeselect dragItem nodeClass columns' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableTreeSpec commentStamp: 'mvdg 3/21/2008 20:59' prior: 0! A pluggable tree widget. PluggableTrees are slightly different from lists in such that they ALWAYS store the actual objects and use the label selector to query for the label of the item. PluggableTrees also behave somewhat differently in such that they do not have a "getSelected" message but only a getSelectedPath message. The difference is that getSelectedPath is used to indicate by the model that the tree should select the appropriate path. This allows disambiguation of items. Because of this, implementations of PluggableTrees must always set their internal selection directly, e.g., rather than sending the model a setSelected message and wait for an update of the #getSelected the implementation must set the selection before sending the #setSelected message. If a client doesn't want this, it can always just signal a change of getSelectedPath to revert to whatever is needed. Instance variables: roots <Symbol> The message to retrieve the roots of the tree. getSelectedPath <Symbol> The message to retrieve the selected path in the tree. setSelected <Symbol> The message to set the selected item in the tree. getChildren <Symbol> The message to retrieve the children of an item hasChildren <Symbol> The message to query for children of an item label <Symbol> The message to query for the label of an item. icon <Symbol> The message to query for the icon of an item. help <Symbol> The message to query for the help of an item. menu <Symbol> The message to query for the tree's menu keyPress <Symbol> The message to process a keystroke. wantsDrop <Symbol> The message to query whether a drop might be accepted. dropItem <Symbol> The message to drop an item. enableDrag <Boolean> Enable dragging from this tree. autoDeselect <Boolean> Whether the tree should allow automatic deselection or not. unusedVar (unused) This variable is a placeholder to fix problems with loading packages in 3.10.! ----- Method: PluggableTreeSpec>>autoDeselect (in category 'accessing') ----- autoDeselect "Answer whether this tree can be automatically deselected" ^autoDeselect ifNil:[true]! ----- Method: PluggableTreeSpec>>autoDeselect: (in category 'accessing') ----- autoDeselect: aBool "Indicate whether this tree can be automatically deselected" autoDeselect := aBool.! ----- Method: PluggableTreeSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableTree: self! ----- Method: PluggableTreeSpec>>columns (in category 'accessing') ----- columns ^ columns! ----- Method: PluggableTreeSpec>>columns: (in category 'accessing') ----- columns: columnSpecs columns := columnSpecs.! ----- Method: PluggableTreeSpec>>dragItem (in category 'accessing') ----- dragItem ^ dragItem.! ----- Method: PluggableTreeSpec>>dragItem: (in category 'accessing') ----- dragItem: aSymbol "Set the selector for dragging an item" dragItem := aSymbol! ----- Method: PluggableTreeSpec>>dropAccept (in category 'accessing') ----- dropAccept "Answer the selector for querying the receiver about accepting drops" ^dropAccept! ----- Method: PluggableTreeSpec>>dropAccept: (in category 'accessing') ----- dropAccept: aSymbol "Set the selector for querying the receiver about accepting drops" dropAccept := aSymbol! ----- Method: PluggableTreeSpec>>dropItem (in category 'accessing') ----- dropItem "Answer the selector for invoking the tree's dragDrop handler" ^dropItem! ----- Method: PluggableTreeSpec>>dropItem: (in category 'accessing') ----- dropItem: aSymbol "Indicate the selector for invoking the tree's dragDrop handler" dropItem := aSymbol! ----- Method: PluggableTreeSpec>>getChildren (in category 'accessing') ----- getChildren "Answer the message to get the children of this tree" ^getChildren! ----- Method: PluggableTreeSpec>>getChildren: (in category 'accessing') ----- getChildren: aSymbol "Indicate the message to retrieve the children of this tree" getChildren := aSymbol! ----- Method: PluggableTreeSpec>>getSelected (in category 'accessing') ----- getSelected ^ getSelected! ----- Method: PluggableTreeSpec>>getSelected: (in category 'accessing') ----- getSelected: aSymbol "Indicate a single node in the tree. Only works if that node is visible, too. Use #getSelectedPath otherwise." getSelected := aSymbol.! ----- Method: PluggableTreeSpec>>getSelectedPath (in category 'accessing') ----- getSelectedPath "Answer the message to retrieve the selection of this tree" ^getSelectedPath! ----- Method: PluggableTreeSpec>>getSelectedPath: (in category 'accessing') ----- getSelectedPath: aSymbol "Indicate the message to retrieve the selection of this tree" getSelectedPath := aSymbol! ----- Method: PluggableTreeSpec>>hasChildren (in category 'accessing') ----- hasChildren "Answer the message to get the existence of children in this tree" ^hasChildren! ----- Method: PluggableTreeSpec>>hasChildren: (in category 'accessing') ----- hasChildren: aSymbol "Indicate the message to retrieve the existence children in this tree" hasChildren := aSymbol! ----- Method: PluggableTreeSpec>>icon (in category 'accessing') ----- icon "Answer the message to get the icons of this tree" ^icon! ----- Method: PluggableTreeSpec>>icon: (in category 'accessing') ----- icon: aSymbol "Indicate the message to retrieve the icon of this tree" icon := aSymbol! ----- Method: PluggableTreeSpec>>keyPress (in category 'accessing') ----- keyPress "Answer the selector for invoking the tree's keyPress handler" ^keyPress! ----- Method: PluggableTreeSpec>>keyPress: (in category 'accessing') ----- keyPress: aSymbol "Indicate the selector for invoking the tree's keyPress handler" keyPress := aSymbol! ----- Method: PluggableTreeSpec>>label (in category 'accessing') ----- label "Answer the message to get the labels of this tree" ^label! ----- Method: PluggableTreeSpec>>label: (in category 'accessing') ----- label: aSymbol "Indicate the message to retrieve the labels of this tree" label := aSymbol! ----- Method: PluggableTreeSpec>>menu (in category 'accessing') ----- menu "Answer the message to get the menus of this tree" ^menu! ----- Method: PluggableTreeSpec>>menu: (in category 'accessing') ----- menu: aSymbol "Indicate the message to retrieve the menus of this tree" menu := aSymbol! ----- Method: PluggableTreeSpec>>nodeClass (in category 'accessing') ----- nodeClass ^ nodeClass! ----- Method: PluggableTreeSpec>>nodeClass: (in category 'accessing') ----- nodeClass: aListWrapperClass nodeClass := aListWrapperClass.! ----- Method: PluggableTreeSpec>>roots (in category 'accessing') ----- roots "Answer the message to retrieve the roots of this tree" ^roots! ----- Method: PluggableTreeSpec>>roots: (in category 'accessing') ----- roots: aSymbol "Indicate the message to retrieve the roots of this tree" roots := aSymbol! ----- Method: PluggableTreeSpec>>setSelected (in category 'accessing') ----- setSelected "Answer the message to set the selection of this tree" ^setSelected! ----- Method: PluggableTreeSpec>>setSelected: (in category 'accessing') ----- setSelected: aSymbol "Indicate the message to set the selection of this tree" setSelected := aSymbol! ----- Method: PluggableTreeSpec>>setSelectedParent (in category 'accessing') ----- setSelectedParent ^ setSelectedParent! ----- Method: PluggableTreeSpec>>setSelectedParent: (in category 'accessing') ----- setSelectedParent: aSymbol setSelectedParent := aSymbol! ----- Method: PluggableTreeSpec>>wantsDrop (in category 'accessing') ----- wantsDrop "Answer the selector for invoking the tree's wantsDrop handler" ^wantsDrop! ----- Method: PluggableTreeSpec>>wantsDrop: (in category 'accessing') ----- wantsDrop: aSymbol "Indicate the selector for invoking the tree's wantsDrop handler" wantsDrop := aSymbol! ----- Method: PluggableWidgetSpec>>color (in category 'accessing') ----- color "Answer the selector for retrieving the button's color" ^color! ----- Method: PluggableWidgetSpec>>color: (in category 'accessing') ----- color: aSymbol "Indicate the selector for retrieving the button's color" color := aSymbol! ----- Method: PluggableWidgetSpec>>frame (in category 'accessing') ----- frame "Answer the receiver's layout frame" ^frame! ----- Method: PluggableWidgetSpec>>frame: (in category 'accessing') ----- frame: aRectangle "Indicate the receiver's layout frame" frame := aRectangle! ----- Method: PluggableWidgetSpec>>horizontalResizing (in category 'layout hints') ----- horizontalResizing ^ horizontalResizing! ----- Method: PluggableWidgetSpec>>horizontalResizing: (in category 'layout hints') ----- horizontalResizing: aSymbol "#rigid, #spaceFill, #shrinkWrap" horizontalResizing := aSymbol.! ----- Method: PluggableWidgetSpec>>margin (in category 'layout hints') ----- margin "Space outside the widgets border. See: http://www.w3.org/wiki/The_CSS_layout_model_-_boxes_borders_margins_padding" ^ margin! ----- Method: PluggableWidgetSpec>>margin: (in category 'layout hints') ----- margin: numberOrPointOrRectangle margin := numberOrPointOrRectangle.! ----- Method: PluggableWidgetSpec>>minimumExtent (in category 'layout hints') ----- minimumExtent ^ minimumExtent ifNil: [-1 @ -1]! ----- Method: PluggableWidgetSpec>>minimumExtent: (in category 'layout hints') ----- minimumExtent: aPoint minimumExtent := aPoint.! ----- Method: PluggableWidgetSpec>>minimumHeight (in category 'layout hints') ----- minimumHeight ^ self minimumExtent y! ----- Method: PluggableWidgetSpec>>minimumHeight: (in category 'layout hints') ----- minimumHeight: aNumber self minimumExtent: self minimumExtent x @ aNumber.! ----- Method: PluggableWidgetSpec>>minimumWidth (in category 'layout hints') ----- minimumWidth ^ self minimumExtent x! ----- Method: PluggableWidgetSpec>>minimumWidth: (in category 'layout hints') ----- minimumWidth: aNumber self minimumExtent: aNumber @ self minimumExtent y.! ----- Method: PluggableWidgetSpec>>model (in category 'accessing') ----- model "Answer the model for which this widget should be built" ^model! ----- Method: PluggableWidgetSpec>>model: (in category 'accessing') ----- model: aModel "Indicate the model for which this widget should be built" model := aModel.! ----- Method: PluggableWidgetSpec>>padding (in category 'layout hints') ----- padding "Space inside the widget's border. See: http://www.w3.org/wiki/The_CSS_layout_model_-_boxes_borders_margins_padding" ^ padding! ----- Method: PluggableWidgetSpec>>padding: (in category 'layout hints') ----- padding: numberOrPointOrRectangle padding := numberOrPointOrRectangle.! ----- Method: PluggableWidgetSpec>>verticalResizing (in category 'layout hints') ----- verticalResizing ^ verticalResizing! ----- Method: PluggableWidgetSpec>>verticalResizing: (in category 'layout hints') ----- verticalResizing: aSymbol "#rigid, #spaceFill, #shrinkWrap" verticalResizing := aSymbol.! ----- Method: ToolBuilderSpec>>buildWith: (in category 'building') ----- buildWith: aBuilder ^self subclassResponsibility! ----- Method: ToolBuilderSpec>>help (in category 'accessing') ----- help "Answer the message to get the help texts of this element." ^ help! ----- Method: ToolBuilderSpec>>help: (in category 'accessing') ----- help: aSymbol "Indicate the message to retrieve the help texts of this element." help := aSymbol! ----- Method: ToolBuilderSpec>>name (in category 'accessing') ----- name ^ name! ----- Method: ToolBuilderSpec>>name: (in category 'accessing') ----- name: anObject name := anObject! Object subclass: #UIManager instanceVariableNames: 'builderClass' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !UIManager commentStamp: 'dtl 5/2/2010 16:06' prior: 0! UIManager is a dispatcher for various user interface requests, such as menu and dialog interactions. An instance of UIManager is associated with each Project to implement the appropriate functions for Morphic, MVC or other user interfaces.! ----- Method: UIManager class>>default (in category 'class initialization') ----- default ^ Project current uiManager! ----- Method: UIManager class>>getDefault (in category 'class initialization') ----- getDefault "Ensure that a more specific manager can always be made by subclassing a tool builder and implementing a more specific way of reacting to #isActiveManager. For example, a BobsUIManager can subclass MorphicUIManager and (if enabled, say Preferences useBobsUI) will be considered before the parent (generic MorphicUIManager)." ^ (self allSubclasses detect: [:any | any isActiveManager and: [any subclasses noneSatisfy: [:sub | sub isActiveManager]]] ifNone: []) ifNotNilDo: [:mgrClass | mgrClass new]! ----- Method: UIManager class>>isActiveManager (in category 'class initialization') ----- isActiveManager "Answer whether I should act as the active ui manager" ^false! ----- Method: UIManager>>builderClass (in category 'builder') ----- builderClass "Answer the kind of tool builder to use, possibly influenced by project preferences" ^ builderClass ifNil: [ builderClass := ToolBuilder findDefault ]! ----- Method: UIManager>>builderClass: (in category 'accessing') ----- builderClass: aClass builderClass := aClass! ----- Method: UIManager>>chooseClassOrTrait (in category 'ui requests') ----- chooseClassOrTrait "Let the user choose a Class or Trait" ^self chooseClassOrTrait: 'Class name or fragment?'! ----- Method: UIManager>>chooseClassOrTrait: (in category 'ui requests') ----- chooseClassOrTrait: label "Let the user choose a Class or Trait" ^self chooseClassOrTrait: label from: Smalltalk environment! ----- Method: UIManager>>chooseClassOrTrait:from: (in category 'ui requests') ----- chooseClassOrTrait: label from: environment "Let the user choose a Class or Trait." | pattern | pattern := self request: label. ^ self classOrTraitFrom: environment pattern: pattern label: label ! ----- Method: UIManager>>chooseDirectory (in category 'ui requests') ----- chooseDirectory "Let the user choose a directory" ^self chooseDirectoryFrom: FileDirectory default! ----- Method: UIManager>>chooseDirectory: (in category 'ui requests') ----- chooseDirectory: label "Let the user choose a directory" ^self chooseDirectory: label from: FileDirectory default! ----- Method: UIManager>>chooseDirectory:from: (in category 'ui requests') ----- chooseDirectory: label from: dir "Let the user choose a directory" ^self subclassResponsibility! ----- Method: UIManager>>chooseDirectoryFrom: (in category 'ui requests') ----- chooseDirectoryFrom: dir "Let the user choose a directory" ^self chooseDirectory: nil from: dir! ----- Method: UIManager>>chooseFileMatching: (in category 'ui requests') ----- chooseFileMatching: patterns "Let the user choose a file matching the given patterns" ^self chooseFileMatching: patterns label: nil! ----- Method: UIManager>>chooseFileMatching:label: (in category 'ui requests') ----- chooseFileMatching: patterns label: labelString "Let the user choose a file matching the given patterns" ^self subclassResponsibility! ----- Method: UIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- chooseFont: titleString for: aModel setSelector: setSelector getSelector: getSelector "Open a font-chooser for the given model"! ----- Method: UIManager>>chooseFrom: (in category 'ui requests') ----- chooseFrom: aList "Choose an item from the given list. Answer the index of the selected item." ^self chooseFrom: aList lines: #()! ----- Method: UIManager>>chooseFrom:lines: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray "Choose an item from the given list. Answer the index of the selected item." ^self chooseFrom: aList lines: linesArray title: ''! ----- Method: UIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the index of the selected item." ^self subclassResponsibility! ----- Method: UIManager>>chooseFrom:title: (in category 'ui requests') ----- chooseFrom: aList title: aString "Choose an item from the given list. Answer the index of the selected item." ^self chooseFrom: aList lines: #() title: aString! ----- Method: UIManager>>chooseFrom:values: (in category 'ui requests') ----- chooseFrom: labelList values: valueList "Choose an item from the given list. Answer the selected item." ^self chooseFrom: labelList values: valueList lines: #()! ----- Method: UIManager>>chooseFrom:values:lines: (in category 'ui requests') ----- chooseFrom: labelList values: valueList lines: linesArray "Choose an item from the given list. Answer the selected item." ^self chooseFrom: labelList values: valueList lines: linesArray title: ''! ----- Method: UIManager>>chooseFrom:values:lines:title: (in category 'ui requests') ----- chooseFrom: labelList values: valueList lines: linesArray title: aString "Choose an item from the given list. Answer the selected item." ^self subclassResponsibility! ----- Method: UIManager>>chooseFrom:values:title: (in category 'ui requests') ----- chooseFrom: labelList values: valueList title: aString "Choose an item from the given list. Answer the selected item." ^self chooseFrom: labelList values: valueList lines: #() title: aString! ----- Method: UIManager>>chooseMultipleFrom: (in category 'ui requests') ----- chooseMultipleFrom: aList "Choose one or more items from the given list. Answer the indices of the selected items." ^ self chooseMultipleFrom: aList lines: #()! ----- Method: UIManager>>chooseMultipleFrom:lines: (in category 'ui requests') ----- chooseMultipleFrom: aList lines: linesArray "Choose one or more items from the given list. Answer the indices of the selected items." ^ self chooseMultipleFrom: aList lines: linesArray title: ''! ----- Method: UIManager>>chooseMultipleFrom:lines:title: (in category 'ui requests') ----- chooseMultipleFrom: aList lines: linesArray title: aString "Choose one or more items from the given list. Answer the indices of the selected items." ^ (self chooseFrom: aList lines: linesArray title: aString) in: [:result | result = 0 ifTrue: [#()] ifFalse: [{result}]]! ----- Method: UIManager>>chooseMultipleFrom:title: (in category 'ui requests') ----- chooseMultipleFrom: aList title: aString "Choose one or more items from the given list. Answer the indices of the selected items." ^self chooseMultipleFrom: aList lines: #() title: aString! ----- Method: UIManager>>chooseMultipleFrom:values: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList "Choose one or more items from the given list. Answer the selected items." ^ self chooseMultipleFrom: labelList values: valueList lines: #()! ----- Method: UIManager>>chooseMultipleFrom:values:lines: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList lines: linesArray "Choose one or more items from the given list. Answer the selected items." ^ self chooseMultipleFrom: labelList values: valueList lines: linesArray title: ''! ----- Method: UIManager>>chooseMultipleFrom:values:lines:title: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList lines: linesArray title: aString "Choose one or more items from the given list. Answer the selected items." ^ (self chooseFrom: labelList values: valueList lines: linesArray title: aString) ifNil: [#()] ifNotNil: [:resultValue | {resultValue}]! ----- Method: UIManager>>chooseMultipleFrom:values:title: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList title: aString "Choose one or more items from the given list. Answer the selected items." ^ self chooseMultipleFrom: labelList values: valueList lines: #() title: aString! ----- Method: UIManager>>classFromPattern:withCaption: (in category 'system introspecting') ----- classFromPattern: pattern withCaption: aCaption "If there is a class or trait whose name exactly given by pattern, return it. If there is only one class or trait in the system whose name matches pattern, return it. Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. This method ignores separator characters in the pattern" ^self classOrTraitFrom: Smalltalk environment pattern: pattern label: aCaption " self classFromPattern: 'CharRecog' withCaption: '' self classFromPattern: 'rRecog' withCaption: '' self classFromPattern: 'znak' withCaption: '' self classFromPattern: 'orph' withCaption: '' self classFromPattern: 'TCompil' withCaption: '' " ! ----- Method: UIManager>>classOrTraitFrom:pattern:label: (in category 'system introspecting') ----- classOrTraitFrom: environment pattern: pattern label: label "If there is a class or trait whose name exactly given by pattern, return it. If there is only one class or trait in the given environment whose name matches pattern, return it. Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. This method ignores separator characters in the pattern" | toMatch potentialNames names exactMatch lines reducedIdentifiers selectedIndex | toMatch := pattern copyWithoutAll: Character separators. toMatch ifEmpty: [ ^nil ]. "If there's a class or trait named as pattern, then return it." Symbol hasInterned: pattern ifTrue: [ :symbol | environment at: symbol ifPresent: [ :maybeClassOrTrait | ((maybeClassOrTrait isKindOf: Class) or: [ maybeClassOrTrait isTrait ]) ifTrue: [ ^maybeClassOrTrait ] ] ]. "No exact match, look for potential matches." toMatch := pattern asLowercase copyWithout: $.. potentialNames := (environment classAndTraitNames) asOrderedCollection. names := pattern last = $. "This is some old hack, using String>>#match: may be better." ifTrue: [ potentialNames select: [ :each | each asLowercase = toMatch ] ] ifFalse: [ potentialNames select: [ :each | each includesSubstring: toMatch caseSensitive: false ] ]. exactMatch := names detect: [ :each | each asLowercase = toMatch ] ifNone: [ nil ]. lines := OrderedCollection new. exactMatch ifNotNil: [ lines add: 1 ]. "Also try some fuzzy matching." reducedIdentifiers := pattern suggestedTypeNames select: [ :each | potentialNames includes: each ]. reducedIdentifiers ifNotEmpty: [ names addAll: reducedIdentifiers. lines add: 1 + names size + reducedIdentifiers size ]. "Let the user select if there's more than one possible match. This may give surprising results." selectedIndex := names size = 1 ifTrue: [ 1 ] ifFalse: [ exactMatch ifNotNil: [ names addFirst: exactMatch ]. self chooseFrom: names lines: lines title: label ]. selectedIndex = 0 ifTrue: [ ^nil ]. ^environment at: (names at: selectedIndex) asSymbol! ----- Method: UIManager>>confirm: (in category 'ui requests') ----- confirm: queryString "Put up a yes/no menu with caption queryString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." ^self subclassResponsibility! ----- Method: UIManager>>confirm:orCancel: (in category 'ui requests') ----- confirm: aString orCancel: cancelBlock "Put up a yes/no/cancel menu with caption aString. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." ^self subclassResponsibility! ----- Method: UIManager>>confirm:orCancel:title: (in category 'ui requests') ----- confirm: aString orCancel: cancelBlock title: titleString "Put up a yes/no/cancel menu with caption aString, and titleString to label the dialog. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." ^self subclassResponsibility! ----- Method: UIManager>>confirm:title: (in category 'ui requests') ----- confirm: queryString title: titleString "Put up a yes/no menu with caption queryString, and titleString to label the dialog. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." ^self subclassResponsibility! ----- Method: UIManager>>confirm:title:trueChoice:falseChoice: (in category 'ui requests') ----- confirm: queryString title: titleString trueChoice: trueChoice falseChoice: falseChoice "Put up a yes/no menu with caption queryString, and titleString to label the dialog. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it is the false-choice. This is a modal question -- the user must respond one way or the other." ^self subclassResponsibility! ----- Method: UIManager>>confirm:trueChoice:falseChoice: (in category 'ui requests') ----- confirm: queryString trueChoice: trueChoice falseChoice: falseChoice "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. This is a modal question -- the user must respond one way or the other." ^self subclassResponsibility! ----- Method: UIManager>>displayProgress:at:from:to:during: (in category 'ui requests') ----- displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock "Display titleString as a caption over a progress bar while workBlock is evaluated." ^self subclassResponsibility! ----- Method: UIManager>>edit: (in category 'ui requests') ----- edit: aText "Open an editor on the given string/text" ^self edit: aText label: nil! ----- Method: UIManager>>edit:label: (in category 'ui requests') ----- edit: aText label: labelString "Open an editor on the given string/text" ^self edit: aText label: labelString accept: nil! ----- Method: UIManager>>edit:label:accept: (in category 'ui requests') ----- edit: aText label: labelString accept: anAction "Open an editor on the given string/text" ^self subclassResponsibility! ----- Method: UIManager>>inform: (in category 'ui requests') ----- inform: aString "Display a message for the user to read and then dismiss" ^self subclassResponsibility! ----- Method: UIManager>>informUser:during: (in category 'ui requests') ----- informUser: aString during: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block. UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]. " ^self informUserDuring:[:bar| bar value: aString. aBlock value].! ----- Method: UIManager>>informUserDuring: (in category 'ui requests') ----- informUserDuring: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block. UIManager default informUserDuring:[:bar| #(one two three) do:[:info| bar value: info. (Delay forSeconds: 1) wait]]" ^self subclassResponsibility! ----- Method: UIManager>>multiLineRequest:centerAt:initialAnswer:answerHeight: (in category 'ui requests') ----- multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight "Create a multi-line instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer nil if the user cancels. An empty string returned means that the ussr cleared the editing area and then hit 'accept'. Because multiple lines are invited, we ask that the user use the ENTER key, or (in morphic anyway) hit the 'accept' button, to submit; that way, the return key can be typed to move to the next line." ^self subclassResponsibility! ----- Method: UIManager>>newDisplayDepthNoRestore: (in category 'display') ----- newDisplayDepthNoRestore: pixelSize self subclassResponsibility.! ----- Method: UIManager>>request: (in category 'ui requests') ----- request: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." ^self request: queryString initialAnswer: ''! ----- Method: UIManager>>request:initialAnswer: (in category 'ui requests') ----- request: queryString initialAnswer: defaultAnswer "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." ^self subclassResponsibility! ----- Method: UIManager>>request:initialAnswer:centerAt: (in category 'ui requests') ----- request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." ^self subclassResponsibility! ----- Method: UIManager>>requestPassword: (in category 'ui requests') ----- requestPassword: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." ^self subclassResponsibility! ----- Method: UIManager>>restoreDisplay (in category 'display') ----- restoreDisplay self subclassResponsibility.! ----- Method: UIManager>>restoreDisplayAfter: (in category 'display') ----- restoreDisplayAfter: aBlock self subclassResponsibility.! ----- Method: UIManager>>screenBounds (in category 'accessing') ----- screenBounds ^ Display boundingBox! ----- Method: UIManager>>toolBuilder (in category 'builder') ----- toolBuilder ^ self builderClass new!

1 0

Squeak 4.6: Help-Squeak-TerseGuide-kfr.5.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of Help-Squeak-TerseGuide to project Squeak 4.6: http://source.squeak.org/squeak46/Help-Squeak-TerseGuide-kfr.5.mcz ==================== Summary ==================== Name: Help-Squeak-TerseGuide-kfr.5 Author: kfr Time: 7 May 2015, 9:38:42.385 am UUID: 75a587af-6dbb-ee4b-b469-ad18259f34f8 Ancestors: Help-Squeak-TerseGuide-dhn.4 Expanded Rectangle guide a little ==================== Snapshot ==================== SystemOrganization addCategory: #'Help-Squeak-TerseGuide'! CustomHelp subclass: #TerseGuideHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Help-Squeak-TerseGuide'! !TerseGuideHelp commentStamp: 'dtl 11/26/2010 12:17' prior: 0! TerseGuideHelp contains the Squeak terse guide by Chris Rathman (http://www.angelfire.com/tx4/cus/notes/smalltalk.html), maintained on the swiki at http://wiki.squeak.org/squeak/5699. Copyrights and credit for the original document belong to Chris Rathman. The original document was formatted for printing with a fixed font. Here it is reformatted for display in a help browser, with various updates and corrections to match the current state of the Squeak image. The contents of the help pages may be evaluated as workspace expressions. HelpBrowser openOn: TerseGuideHelp ! ----- Method: TerseGuideHelp class>>arithmetic (in category 'pages') ----- arithmetic ^HelpTopic title: 'Arithmetic Expressions' contents: '"************************************************************************ * Arithmetic expressions: * ************************************************************************" | x | x := 6 + 3. "addition" x := 6 - 3. "subtraction" x := 6 * 3. "multiplication" x := 1 + 2 * 3. "evaluation always left to right (1 + 2) * 3" x := 5 / 3. "division with fractional result" x := 5.0 / 3.0. "division with float result" x := 5.0 // 3.0. "integer divide" x := 5.0 \\ 3.0. "integer remainder" x := -5. "unary minus" x := 5 sign. "numeric sign (1, -1 or 0)" x := 5 negated. "negate receiver" x := 1.2 integerPart. "integer part of number (1.0)" x := 1.2 fractionPart. "fractional part of number (0.2)" x := 5 reciprocal. "reciprocal function" x := 6 * 3.1. "auto convert to float" x := 5 squared. "square function" x := 25 sqrt. "square root" x := 5 raisedTo: 2. "power function" x := 5 raisedToInteger: 2. "power function with integer" x := 5 exp. "exponential" x := -5 abs. "absolute value" x := 3.99 rounded. "round" x := 3.99 truncated. "truncate" x := 3.99 roundTo: 1. "round to specified decimal places" x := 3.99 truncateTo: 1. "truncate to specified decimal places" x := 3.99 floor. "truncate" x := 3.99 ceiling. "round up" x := 5 factorial. "factorial" x := -5 quo: 3. "integer divide rounded toward zero" x := -5 rem: 3. "integer remainder rounded toward zero" x := 28 gcd: 12. "greatest common denominator" x := 28 lcm: 12. "least common multiple" x := 100 ln. "natural logarithm" x := 100 log. "base 10 logarithm" x := 100 log: 10 . "logarithm with specified base" x := 100 floorLog: 10. "floor of the log" x := 180 degreesToRadians. "convert degrees to radians" x := 3.14 radiansToDegrees. "convert radians to degrees" x := 0.7 sin. "sine" x := 0.7 cos. "cosine" x := 0.7 tan. "tangent" x := 0.7 arcSin. "arcsine" x := 0.7 arcCos. "arccosine" x := 0.7 arcTan. "arctangent" x := 10 max: 20. "get maximum of two numbers" x := 10 min: 20. "get minimum of two numbers" x := Float pi. "pi" x := Float e. "exp constant" x := Float infinity. "infinity" x := Float nan. "not-a-number" x := Random new next; yourself. x next. "random number stream (0.0 to 1.0)" x := 100 atRandom. "quick random number" '! ----- Method: TerseGuideHelp class>>array (in category 'pages') ----- array ^HelpTopic title: 'Array' contents: '"************************************************************************ * Array: Fixed length collection * * ByteArray: Array limited to byte elements (0-255) * * WordArray: Array limited to word elements (0-2^32) * ************************************************************************" | b x y sum max | x := #(4 3 2 1). "constant array" x := Array with: 5 with: 4 with: 3 with: 2. "create array with up to 4 elements" x := Array new: 4. "allocate an array with specified size" x "set array elements" at: 1 put: 5; at: 2 put: 4; at: 3 put: 3; at: 4 put: 2. b := x isEmpty. "test if array is empty" y := x size. "array size" y := x at: 4. "get array element at index" b := x includes: 3. "test if element is in array" y := x copyFrom: 2 to: 4. "subarray" y := x indexOf: 3 ifAbsent: [0]. "first position of element within array" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the array" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a < 3]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum array elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum array elements" sum := x inject: 0 into: [:a :c | a + c]. "sum array elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in array" ifTrue: [a] ifFalse: [c]]. y := x shuffled. "randomly shuffle collection" y := x asArray. "convert to array" y := x asByteArray. "convert to byte array" y := x asWordArray. "convert to word array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>assignment (in category 'pages') ----- assignment ^HelpTopic title: 'Assignment' contents: '"************************************************************************ * Assignment: * ************************************************************************" | x y z | x _ 4. "assignment (Squeak) <-" x := 5. "assignment" x := y := z := 6. "compound assignment" x := (y := 6) + 1. x := Object new. "bind to allocated instance of a class" x := 123 class. "discover the object class" x := Integer superclass. "discover the superclass of a class" x := Object allInstances. "get an array of all instances of a class" x := Integer allSuperclasses. "get all superclasses of a class" x := 1.2 hash. "hash value for object" y := x copy. "copy object" y := x shallowCopy. "copy object (not overridden)" y := x deepCopy. "copy object and instance vars" y := x veryDeepCopy. "complete tree copy using a dictionary" '! ----- Method: TerseGuideHelp class>>association (in category 'pages') ----- association ^HelpTopic title: 'Association' contents: '"************************************************************************ * Associations: * ************************************************************************" | x y | x := #myVar->''hello''. y := x key. y := x value. '! ----- Method: TerseGuideHelp class>>bag (in category 'pages') ----- bag ^HelpTopic title: 'Bag' contents: '"************************************************************************ * Bag: like OrderedCollection except elements are in no * * particular order * ************************************************************************" | b x y sum max | x := Bag with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := Bag new. "allocate collection" x add: 4; add: 3; add: 1; add: 2; yourself. "add element to collection" x add: 3 withOccurrences: 2. "add multiple copies to collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" y := x remove: 4 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" b := x includes: 3. "test if element is in collection" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>bitwise (in category 'pages') ----- bitwise ^HelpTopic title: 'Bitwise Manipulation' contents: '"************************************************************************ * Bitwise Manipulation: * ************************************************************************" | b x | x := 16rFF bitAnd: 16r0F. "and bits" x := 16rF0 bitOr: 16r0F. "or bits" x := 16rFF bitXor: 16r0F. "xor bits" x := 16rFF bitInvert. "invert bits" x := 16r0F bitShift: 4. "left shift" x := 16rF0 bitShift: -4. "right shift" x := 16r80 bitAt: 8. "bit at position (0|1)" x := 16r80 highBit. "position of highest bit set" b := 16rFF allMask: 16r0F. "test if all bits set in mask set in receiver" b := 16rFF anyMask: 16r0F. "test if any bits set in mask set in receiver" b := 16rFF noMask: 16r0F. "test if all bits set in mask clear in receiver" '! ----- Method: TerseGuideHelp class>>block (in category 'pages') ----- block ^HelpTopic title: 'Blocks' contents: '"************************************************************************ * Blocks: * * - blocks are objects and may be assigned to a variable * * - value is last expression evaluated unless explicit return * * - blocks may be nested * * - specification [ arguments | | localvars | expressions ] * * - ^expression terminates block & method (exits all nested blocks) * * - blocks intended for long term storage should not contain ^ * ************************************************************************" | x y z fac | x := [ y := 1. z := 2. ]. x value. "simple block usage" x := [ :argOne :argTwo | argOne, '' and '' , argTwo.]. "set up block with argument passing" Transcript show: (x value: ''First'' value: ''Second''); cr. "use block with argument passing" x := [:e | | v | v := 1. e + v] value: 2. "localvar in a block" fac := [ :n | n > 1 ifTrue: [n * (fac value: n-1)] ifFalse: [1]]. "closure on block variable" fac value: 5. "closure variable scoped to its block" '! ----- Method: TerseGuideHelp class>>bookName (in category 'accessing') ----- bookName ^'Terse Guide'! ----- Method: TerseGuideHelp class>>boolean (in category 'pages') ----- boolean ^HelpTopic title: 'Boolean' contents: '"************************************************************************ * Booleans: * ************************************************************************" | b x y | x := 1. y := 2. b := (x = y). "equals" b := (x ~= y). "not equals" b := (x == y). "identical" b := (x ~~ y). "not identical" b := (x > y). "greater than" b := (x < y). "less than" b := (x >= y). "greater than or equal" b := (x <= y). "less than or equal" b := b not. "boolean not" b := (x < 5) & (y > 1). "boolean and" b := (x < 5) | (y > 1). "boolean or" b := (x < 5) and: [y > 1]. "boolean and (short-circuit)" b := (x < 5) or: [y > 1]. "boolean or (short-circuit)" b := (x < 5) eqv: (y > 1). "test if both true or both false" b := (x < 5) xor: (y > 1). "test if one true and other false" b := 5 between: 3 and: 12. "between (inclusive)" b := 123 isKindOf: Number. "test if object is class or subclass of" b := 123 isMemberOf: SmallInteger. "test if object is type of class" b := 123 respondsTo: #sqrt. "test if object responds to message" b := x isNil. "test if object is nil" b := x isZero. "test if number is zero" b := x positive. "test if number is positive" b := x strictlyPositive. "test if number is greater than zero" b := x negative. "test if number is negative" b := x even. "test if number is even" b := x odd. "test if number is odd" b := x isLiteral. "test if literal constant" b := x isInteger. "test if object is integer" b := x isFloat. "test if object is float" b := x isNumber. "test if object is number" b := $A isUppercase. "test if upper case character" b := $A isLowercase. "test if lower case character" '! ----- Method: TerseGuideHelp class>>character (in category 'pages') ----- character ^HelpTopic title: 'Character' contents: '"************************************************************************ * Character: * ************************************************************************" | x y b | x := $A. "character assignment" y := x isLowercase. "test if lower case" y := x isUppercase. "test if upper case" y := x isLetter. "test if letter" y := x isDigit. "test if digit" y := x isAlphaNumeric. "test if alphanumeric" y := x isSeparator. "test if seperator char" y := x isVowel. "test if vowel" y := x digitValue. "convert to numeric digit value" y := x asLowercase. "convert to lower case" y := x asUppercase. "convert to upper case" y := x asciiValue. "convert to numeric ascii value" y := x asString. "convert to string" b := $A <= $B. "comparison" y := $A max: $B. '! ----- Method: TerseGuideHelp class>>conditionalStatement (in category 'pages') ----- conditionalStatement ^HelpTopic title: 'Conditional Statement' contents: '"************************************************************************ * Conditional Statements: * ************************************************************************" | x switch result | x := 11. x > 10 ifTrue: [Transcript show: ''ifTrue''; cr]. "if then" x > 10 ifFalse: [Transcript show: ''ifFalse''; cr]. "if else" x > 10 "if then else" ifTrue: [Transcript show: ''ifTrue''; cr] ifFalse: [Transcript show: ''ifFalse''; cr]. x > 10 "if else then" ifFalse: [Transcript show: ''ifFalse''; cr] ifTrue: [Transcript show: ''ifTrue''; cr]. Transcript show: (x > 10 ifTrue: [''ifTrue''] ifFalse: [''ifFalse'']); cr. Transcript "nested if then else" show: (x > 10 ifTrue: [x > 5 ifTrue: [''A''] ifFalse: [''B'']] ifFalse: [''C'']); cr. switch := Dictionary new. "switch functionality" switch at: $A put: [Transcript show: ''Case A''; cr]. switch at: $B put: [Transcript show: ''Case B''; cr]. switch at: $C put: [Transcript show: ''Case C''; cr]. result := (switch at: $B) value. '! ----- Method: TerseGuideHelp class>>constants (in category 'pages') ----- constants ^HelpTopic title: 'Constants' contents: '"************************************************************************ * Constants: * ************************************************************************" | b x | b := true. "true constant" b := false. "false constant" x := nil. "nil object constant" x := 1. "integer constants" x := 3.14. "float constants" x := 2e-2. "fractional constants" x := 16r0F. "hex constant". x := -1. "negative constants" x := ''Hello''. "string constant" x := ''I''''m here''. "single quote escape" x := $A. "character constant" x := $ . "character constant (space)" x := #aSymbol. "symbol constants" x := #(3 2 1). "array constants" x := #(''abc'' 2 $a). "mixing of types allowed" '! ----- Method: TerseGuideHelp class>>conversion (in category 'pages') ----- conversion ^HelpTopic title: 'Conversion' contents: '"************************************************************************ * Conversion: * ************************************************************************" | x | x := 3.99 asInteger. "convert number to integer (truncates in Squeak)" x := 3.99 asFraction. "convert number to fraction" x := 3 asFloat. "convert number to float" x := 65 asCharacter. "convert integer to character" x := $A asciiValue. "convert character to integer" x := 3.99 printString. "convert object to string via printOn:" x := 3.99 storeString. "convert object to string via storeOn:" x := 15 radix: 16. "convert to string in given base" x := 15 printStringBase: 16. x := 15 storeStringBase: 16. '! ----- Method: TerseGuideHelp class>>date (in category 'pages') ----- date ^HelpTopic title: 'Date' contents: '"************************************************************************ * Date: * ************************************************************************" | x y b | x := Date today. "create date for today" x := Date dateAndTimeNow. "create date from current time/date" x := Date readFromString: ''01/02/1999''. "create date from formatted string" x := Date newDay: 12 month: #July year: 1999. "create date from parts" x := Date fromDays: 36000. "create date from elapsed days since 1/1/1901" y := Date dayOfWeek: #Monday. "day of week as int (1-7)" y := Date indexOfMonth: #January. "month of year as int (1-12)" y := Date daysInMonth: 2 forYear: 1996. "day of month as int (1-31)" y := Date daysInYear: 1996. "days in year (365|366)" y := Date nameOfDay: 1. "weekday name (#Monday,...)" y := Date nameOfMonth: 1. "month name (#January,...)" y := Date leapYear: 1996. "1 if leap year; 0 if not leap year" y := x weekday. "day of week (#Monday,...)" y := x previous: #Monday. "date for previous day of week" y := x dayOfMonth. "day of month (1-31)" y := x day. "day of year (1-366)" y := x firstDayOfMonth. "day of year for first day of month" y := x monthName. "month of year (#January,...)" y := x monthIndex. "month of year (1-12)" y := x daysInMonth. "days in month (1-31)" y := x year. "year (19xx)" y := x daysInYear. "days in year (365|366)" y := x daysLeftInYear. "days left in year (364|365)" y := x asSeconds. "seconds elapsed since 1/1/1901" y := x addDays: 10. "add days to date object" y := x subtractDays: 10. "subtract days to date object" y := x subtractDate: (Date today). "subtract date (result in days)" y := x printFormat: #(2 1 3 $/ 1 1). "print formatted date" b := (x <= Date today). "comparison" '! ----- Method: TerseGuideHelp class>>debugging (in category 'pages') ----- debugging ^HelpTopic title: 'Debugging' contents: '"************************************************************************ * debugging: * ************************************************************************" | a b x | x := Object new. x yourself. "returns receiver" String browse. "browse specified class" x inspect. "open object inspector window" x confirm: ''Is this correct?''. x halt. "breakpoint to open debugger window" x halt: ''Halt message''. x notify: ''Notify text''. x error: ''Error string''. "open up error window with title" x shouldNotImplement. "flag message should not be implemented" x subclassResponsibility. "flag message as abstract" x errorImproperStore. "flag an improper store into indexable object" x errorNonIntegerIndex. "flag only integers should be used as index" x errorSubscriptBounds: 13. "flag subscript out of bounds" x primitiveFailed. "system primitive failed" a := ''A1''. b := ''B2''. a become: b. "switch two objects" Transcript show: a, b; cr. x doesNotUnderstand: (Message selector: #foo). "flag message is not handled" '! ----- Method: TerseGuideHelp class>>dictionary (in category 'pages') ----- dictionary ^HelpTopic title: 'Dictionary' contents: '"************************************************************************ * Dictionary: * * IdentityDictionary: uses identity test (== rather than =) * ************************************************************************" | b x y sum max | x := Dictionary new. "allocate collection" x add: #a->4; add: #b->3; add: #c->1; add: #d->2; yourself. "add element to collection" x at: #e put: 3. "set element at index" b := x isEmpty. "test if empty" y := x size. "number of elements" y := x at: #a ifAbsent: []. "retrieve element at index" y := x keyAtValue: 3 ifAbsent: []. "retrieve key for given value with error block" y := x removeKey: #e ifAbsent: []. "remove element from collection" b := x includes: 3. "test if element is in values collection" b := x includesKey: #a. "test if element is in keys collection" y := x occurrencesOf: 3. "number of times object in collection" y := x keys. "set of keys" y := x values. "bag of values" x do: [:a | Transcript show: a printString; cr]. "iterate over the values collection" x keysDo: [:a | Transcript show: a printString; cr]. "iterate over the keys collection" x associationsDo: [:a | Transcript show: a printString; cr]. "iterate over the associations" x keysAndValuesDo: [:aKey :aValue | Transcript "iterate over keys and values" show: aKey printString; space; show: aValue printString; cr]. b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" Smalltalk at: #CMRGlobal put: ''CMR entry''. "put global in Smalltalk Dictionary" x := Smalltalk at: #CMRGlobal. "read global from Smalltalk Dictionary" Transcript show: (CMRGlobal printString). "entries are directly accessible by name" Smalltalk keys do: [ :k | "print out all classes" ((Smalltalk at: k) isKindOf: Class) ifFalse: [Transcript show: k printString; cr]]. Smalltalk at: #CMRDictionary put: (Dictionary new). "set up user defined dictionary" CMRDictionary at: #MyVar1 put: ''hello1''. "put entry in dictionary" CMRDictionary add: #MyVar2->''hello2''. "add entry to dictionary use key->value combo" CMRDictionary size. "dictionary size" CMRDictionary keys do: [ :k | "print out keys in dictionary" Transcript show: k printString; cr]. CMRDictionary values do: [ :k | "print out values in dictionary" Transcript show: k printString; cr]. CMRDictionary keysAndValuesDo: [:aKey :aValue | "print out keys and values" Transcript show: aKey printString; space; show: aValue printString; cr]. CMRDictionary associationsDo: [:aKeyValue | "another iterator for printing key values" Transcript show: aKeyValue printString; cr]. Smalltalk removeKey: #CMRGlobal ifAbsent: []. "remove entry from Smalltalk dictionary" Smalltalk removeKey: #CMRDictionary ifAbsent: []. "remove user dictionary from Smalltalk dictionary" '! ----- Method: TerseGuideHelp class>>dynamic (in category 'pages') ----- dynamic ^HelpTopic title: 'Dynamic Message Calling/Compiling' contents: '"************************************************************************ * Dynamic Message Calling/Compiling: * ************************************************************************" | receiver message result argument keyword1 keyword2 argument1 argument2 | "unary message" receiver := 5. message := ''factorial'' asSymbol. result := receiver perform: message. result := Compiler evaluate: ((receiver storeString), '' '', message). result := (Message new setSelector: message arguments: #()) sentTo: receiver. "binary message" receiver := 1. message := ''+'' asSymbol. argument := 2. result := receiver perform: message withArguments: (Array with: argument). result := Compiler evaluate: ((receiver storeString), '' '', message, '' '', (argument storeString)). result := (Message new setSelector: message arguments: (Array with: argument)) sentTo: receiver. "keyword messages" receiver := 12. keyword1 := ''between:'' asSymbol. keyword2 := ''and:'' asSymbol. argument1 := 10. argument2 := 20. result := receiver perform: (keyword1, keyword2) asSymbol withArguments: (Array with: argument1 with: argument2). result := Compiler evaluate: ((receiver storeString), '' '', keyword1, (argument1 storeString) , '' '', keyword2, (argument2 storeString)). result := (Message new setSelector: (keyword1, keyword2) asSymbol arguments: (Array with: argument1 with: argument2)) sentTo: receiver. '! ----- Method: TerseGuideHelp class>>fileStream (in category 'pages') ----- fileStream ^HelpTopic title: 'File Stream' contents: '"************************************************************************ * FileStream: * ************************************************************************" | b x ios | ios := FileStream newFileNamed: ''ios.txt''. ios nextPut: $H; cr. ios nextPutAll: ''Hello File''; cr. ''Hello File'' printOn: ios. ''Hello File'' storeOn: ios. ios close. ios := FileStream oldFileNamed: ''ios.txt''. [(x := ios nextLine) notNil] whileTrue: [Transcript show: x; cr]. ios position: 3. x := ios position. x := ios next. x := ios peek. b := ios atEnd. ios close. '! ----- Method: TerseGuideHelp class>>internalStream (in category 'pages') ----- internalStream ^HelpTopic title: 'Internal Stream' contents: '"************************************************************************ * Internal Stream: * ************************************************************************" | b x ios | ios := ReadStream on: ''Hello read stream''. ios := ReadStream on: ''Hello read stream'' from: 1 to: 5. [(x := ios nextLine) notNil] whileTrue: [Transcript show: x; cr]. ios position: 3. ios position. x := ios next. x := ios peek. x := ios contents. b := ios atEnd. ios := ReadWriteStream on: ''Hello read stream''. ios := ReadWriteStream on: ''Hello read stream'' from: 1 to: 5. ios := ReadWriteStream with: ''Hello read stream''. ios := ReadWriteStream with: ''Hello read stream'' from: 1 to: 10. ios position: 0. [(x := ios nextLine) notNil] whileTrue: [Transcript show: x; cr]. ios position: 6. ios position. ios nextPutAll: ''Chris''. x := ios next. x := ios peek. x := ios contents. b := ios atEnd. '! ----- Method: TerseGuideHelp class>>interval (in category 'pages') ----- interval ^HelpTopic title: 'Interval' contents: '"************************************************************************ * Interval: * ************************************************************************" | b x y sum max | x := Interval from: 5 to: 10. "create interval object" x := 5 to: 10. x := Interval from: 5 to: 10 by: 2. "create interval object with specified increment" x := 5 to: 10 by: 2. b := x isEmpty. "test if empty" y := x size. "number of elements" x includes: 9. "test if element is in collection" x do: [:k | Transcript show: k printString; cr]. "iterate over interval" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 7]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a > 6]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>introduction (in category 'pages') ----- introduction ^HelpTopic title: 'General' contents: '"************************************************************************ * Allowable characters: * * - a-z * * - A-Z * * - 0-9 * * - .+/\*~<>@%|&? * * - blank, tab, cr, ff, lf * * * * Variables: * * - variables must be declared before use * * - shared vars must begin with uppercase * * - local vars must begin with lowercase * * - reserved names: nil, true, false, self, super, and Smalltalk * * * * Variable scope: * * - Global: defined in Dictionary Smalltalk and accessible by all * * objects in system * * - Special: (reserved) Smalltalk, super, self, true, false, & nil * * - Method Temporary: local to a method * * - Block Temporary: local to a block * * - Pool: variables in a Dictionary object * * - Method Parameters: automatic local vars created as a result of * * message call with params * * - Block Parameters: automatic local vars created as a result of * * value: message call * * - Class: shared with all instances of one class & its subclasses * * - Class Instance: unique to each instance of a class * * - Instance Variables: unique to each instance * ************************************************************************" "Comments are enclosed in quotes" "Period (.) is the statement seperator" '! ----- Method: TerseGuideHelp class>>iterationStatement (in category 'pages') ----- iterationStatement ^HelpTopic title: 'Iteration Statement' contents: '"************************************************************************ * Iteration statements: * ************************************************************************" | x y | x := 4. y := 1. [x > 0] whileTrue: [x := x - 1. y := y * 2]. "while true loop" [x >= 4] whileFalse: [x := x + 1. y := y * 2]. "while false loop" x timesRepeat: [y := y * 2]. "times repear loop (i := 1 to x)" 1 to: x do: [:a | y := y * 2]. "for loop" 1 to: x by: 2 do: [:a | y := y / 2]. "for loop with specified increment" #(5 4 3) do: [:a | x := x + a]. "iterate over array elements" '! ----- Method: TerseGuideHelp class>>metaclass (in category 'pages') ----- metaclass ^HelpTopic title: 'Class / Metaclass' contents: '"************************************************************************ * class/meta-class: * ************************************************************************" | b x | x := String name. "class name" x := String category. "organization category" x := String comment. "class comment" x := String kindOfSubclass. "subclass type - subclass: variableSubclass, etc" x := String definition. "class definition" x := String instVarNames. "immediate instance variable names" x := String allInstVarNames. "accumulated instance variable names" x := String classVarNames. "immediate class variable names" x := String allClassVarNames. "accumulated class variable names" x := String sharedPools. "immediate dictionaries used as shared pools" x := String allSharedPools. "accumulated dictionaries used as shared pools" x := String selectors. "message selectors for class" x := String sourceCodeAt: #indexOf:. "source code for specified method" x := String allInstances. "collection of all instances of class" x := String superclass. "immediate superclass" x := String allSuperclasses. "accumulated superclasses" x := String withAllSuperclasses. "receiver class and accumulated superclasses" x := String subclasses. "immediate subclasses" x := String allSubclasses. "accumulated subclasses" x := String withAllSubclasses. "receiver class and accumulated subclasses" b := String instSize. "number of named instance variables" b := String isFixed. "true if no indexed instance variables" b := String isVariable. "true if has indexed instance variables" b := String isPointers. "true if index instance vars contain objects" b := String isBits. "true if index instance vars contain bytes/words" b := String isBytes. "true if index instance vars contain bytes" b := String isWords. "true if index instance vars contain words" Object withAllSubclasses size. "get total number of class entries" '! ----- Method: TerseGuideHelp class>>methodCall (in category 'pages') ----- methodCall ^HelpTopic title: 'Method Call' contents: '"************************************************************************ * Method calls: * * - unary methods are messages with no arguments * * - binary methods * * - keyword methods are messages with selectors including colons * * * * standard categories/protocols: * * - initialize-release (methods called for new instance) * * - accessing (get/set methods) * * - testing (boolean tests - is) * * - comparing (boolean tests with parameter * * - displaying (gui related methods) * * - printing (methods for printing) * * - updating (receive notification of changes) * * - private (methods private to class) * * - instance-creation (class methods for creating instance) * ************************************************************************" | x | x := 2 sqrt. "unary message" x := 2 raisedTo: 10. "keyword message" x := 194 * 9. "binary message" Transcript show: (194 * 9) printString; cr. "combination (chaining)" x := 2 perform: #sqrt. "indirect method invocation" Transcript "Cascading - send multiple messages to receiver" show: ''hello ''; show: ''world''; cr. x := 3 + 2; * 100. "result=300. Sends message to same receiver (3)" '! ----- Method: TerseGuideHelp class>>misc (in category 'pages') ----- misc ^HelpTopic title: 'Miscellaneous' contents: '"************************************************************************ * Misc. * ************************************************************************" | x | "Smalltalk condenseChanges." "compress the change file" x := FillInTheBlank request: ''Prompt Me''. "prompt user for input" x := UIManager default request: ''Prompt Me''. "prompt user for input using a flexible UI dispatcher" Utilities openCommandKeyHelp '! ----- Method: TerseGuideHelp class>>orderedCollection (in category 'pages') ----- orderedCollection ^HelpTopic title: 'Ordered Collection' contents: '"************************************************************************ * OrderedCollection: acts like an expandable array * ************************************************************************" | b x y sum max | x := OrderedCollection with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := OrderedCollection new. "allocate collection" x add: 3; add: 2; add: 1; add: 4; yourself. "add element to collection" y := x addFirst: 5. "add element at beginning of collection" y := x removeFirst. "remove first element in collection" y := x addLast: 6. "add element at end of collection" y := x removeLast. "remove last element in collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" x at: 2 put: 3. "set element at index" y := x remove: 5 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" y := x at: 2. "retrieve element at index" y := x first. "retrieve first element in collection" y := x last. "retrieve last element in collection" b := x includes: 5. "test if element is in collection" y := x copyFrom: 2 to: 3. "subcollection" y := x indexOf: 3 ifAbsent: [0]. "first position of element within collection" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a < 2]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x shuffled. "randomly shuffle collection" y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>pages (in category 'accessing') ----- pages ^ #( introduction transcript assignment constants boolean arithmetic bitwise conversion block methodCall conditionalStatement iterationStatement character symbol string array orderedCollection sortedCollection bag set interval association dictionary internalStream fileStream date time point rectangle pen dynamic metaclass debugging misc )! ----- Method: TerseGuideHelp class>>pen (in category 'pages') ----- pen ^HelpTopic title: 'Pen' contents: '"************************************************************************ * Pen: * ************************************************************************" | myPen | Display restoreAfter: [ Display fillWhite. myPen := Pen new. "get graphic pen" myPen squareNib: 1. myPen color: (Color blue). "set pen color" myPen home. "position pen at center of display" myPen up. "makes nib unable to draw" myPen down. "enable the nib to draw" myPen north. "points direction towards top" myPen turn: -180. "add specified degrees to direction" myPen direction. "get current angle of pen" myPen go: 50. "move pen specified number of pixels" myPen location. "get the pen position" myPen goto: 200@200. "move to specified point" myPen place: 250@250. "move to specified point without drawing" myPen print: ''Hello World'' withFont: (TextStyle default fontAt: 1). Display extent. "get display width@height" Display width. "get display width" Display height. "get display height" ]. '! ----- Method: TerseGuideHelp class>>point (in category 'pages') ----- point ^HelpTopic title: 'Point' contents: '"************************************************************************ * Point: * ************************************************************************" | x y | x := 200@100. "obtain a new point" y := x x. "x coordinate" y := x y. "y coordinate" x := 200@100 negated. "negates x and y" x := (-200@ -100) abs. "absolute value of x and y" x := (200.5(a)100.5) rounded. "round x and y" x := (200.5(a)100.5) truncated. "truncate x and y" x := 200@100 + 100. "add scale to both x and y" x := 200@100 - 100. "subtract scale from both x and y" x := 200@100 * 2. "multiply x and y by scale" x := 200@100 / 2. "divide x and y by scale" x := 200@100 // 2. "divide x and y by scale" x := 200@100 \\ 3. "remainder of x and y by scale" x := 200@100 + (50@25). "add points" x := 200@100 - (50@25). "subtract points" x := 200@100 * (3@4). "multiply points" x := 200@100 // (3@4). "divide points" x := 200@100 max: 50@200. "max x and y" x := 200@100 min: 50@200. "min x and y" x := 20@5 dotProduct: 10@2. "sum of product (x1*x2 + y1*y2)" '! ----- Method: TerseGuideHelp class>>rectangle (in category 'pages') ----- rectangle ^HelpTopic title: 'Rectangle' contents: '"************************************************************************ * Rectangle: * ************************************************************************" Rectangle fromUser. Rectangle origin: 0@0 corner: 100@100 "Origin and corners are absolute points" Rectangle origin: 80@40 extent: 50@50 "Extent is added to origin" Rectangle center: 40@50 extent: 30@20 "Center is half of extent" Rectangle left: 1 right: 20 top: 1 bottom: 10 | col | col := OrderedCollection new. col add: (Rectangle center: 40@50 extent: 30@20). col add: (Rectangle left: 1 right: 20 top: 1 bottom: 10). Rectangle merging: col '! ----- Method: TerseGuideHelp class>>set (in category 'pages') ----- set ^HelpTopic title: 'Set' contents: '"************************************************************************ * Set: like Bag except duplicates not allowed * * IdentitySet: uses identity test (== rather than =) * ************************************************************************" | b x y sum max | x := Set with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := Set new. "allocate collection" x add: 4; add: 3; add: 1; add: 2; yourself. "add element to collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" y := x remove: 4 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" x includes: 4. "test if element is in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>sortedCollection (in category 'pages') ----- sortedCollection ^HelpTopic title: 'Sorted Collection' contents: '"************************************************************************ * SortedCollection: like OrderedCollection except order of elements * * determined by sorting criteria * ************************************************************************" | b x y sum max | x := SortedCollection with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := SortedCollection new. "allocate collection" x := SortedCollection sortBlock: [:a :c | a > c]. "set sort criteria" x add: 3; add: 2; add: 1; add: 4; yourself. "add element to collection" "y := x addFirst: 5." "add element at beginning of collection" y := x removeFirst. "remove first element in collection" y := x addLast: 6. "add element at end of collection" y := x removeLast. "remove last element in collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" y := x remove: 5 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" y := x at: 2. "retrieve element at index" y := x first. "retrieve first element in collection" y := x last. "retrieve last element in collection" b := x includes: 4. "test if element is in collection" y := x copyFrom: 2 to: 3. "subcollection" y := x indexOf: 3 ifAbsent: [0]. "first position of element within collection" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a < 3]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>string (in category 'pages') ----- string ^HelpTopic title: 'String' contents: '"************************************************************************ * String: * ************************************************************************" | b x y | x := ''This is a string''. "string assignment" x := ''String'', ''Concatenation''. "string concatenation" b := x isEmpty. "test if string is empty" y := x size. "string size" y := x at: 2. "char at location" y := x copyFrom: 2 to: 4. "substring" y := x indexOf: $a ifAbsent: [0]. "first position of character within string" x := String new: 4. "allocate string object" x "set string elements" at: 1 put: $a; at: 2 put: $b; at: 3 put: $c; at: 4 put: $e. x := String with: $a with: $b with: $c with: $d. "set up to 4 elements at a time" x do: [:a | Transcript show: a printString; cr]. "iterate over the string" b := x allSatisfy: [:a | (a >= $a) & (a <= $z)]. "test if all elements meet condition" y := x select: [:a | a > $a]. "return all elements that meet condition" y := x asSymbol. "convert string to symbol" y := x asArray. "convert string to array" x := ''ABCD'' asByteArray. "convert string to byte array" y := x asOrderedCollection. "convert string to ordered collection" y := x asSortedCollection. "convert string to sorted collection" y := x asBag. "convert string to bag collection" y := x asSet. "convert string to set collection" y := x shuffled. "randomly shuffle string" '! ----- Method: TerseGuideHelp class>>symbol (in category 'pages') ----- symbol ^HelpTopic title: 'Symbol' contents: '"************************************************************************ * Symbol: * ************************************************************************" | b x y | x := #Hello. "symbol assignment" y := ''String'', ''Concatenation''. "symbol concatenation (result is string)" b := x isEmpty. "test if symbol is empty" y := x size. "string size" y := x at: 2. "char at location" y := x copyFrom: 2 to: 4. "substring" y := x indexOf: $e ifAbsent: [0]. "first position of character within string" x do: [:a | Transcript show: a printString; cr]. "iterate over the string" b := x allSatisfy: [:a | (a >= $a) & (a <= $z)]. "test if all elements meet condition" y := x select: [:a | a > $a]. "return all elements that meet condition" y := x asString. "convert symbol to string" y := x asText. "convert symbol to text" y := x asArray. "convert symbol to array" y := x asOrderedCollection. "convert symbol to ordered collection" y := x asSortedCollection. "convert symbol to sorted collection" y := x asBag. "convert symbol to bag collection" y := x asSet. "convert symbol to set collection" '! ----- Method: TerseGuideHelp class>>time (in category 'pages') ----- time ^HelpTopic title: 'Time' contents: '"************************************************************************ * Time: * ************************************************************************" | x y b | x := Time now. "create time from current time" x := Time dateAndTimeNow. "create time from current time/date" x := Time readFromString: ''3:47:26 pm''. "create time from formatted string" x := Time fromSeconds: (60 * 60 * 4). "create time from elapsed time from midnight" y := Time millisecondClockValue. "milliseconds since midnight" y := Time totalSeconds. "total seconds since 1/1/1901" y := x seconds. "seconds past minute (0-59)" y := x minutes. "minutes past hour (0-59)" y := x hours. "hours past midnight (0-23)" y := x addTime: (Time now). "add time to time object" y := x subtractTime: (Time now). "subtract time to time object" y := x asSeconds. "convert time to seconds" x := Time millisecondsToRun: [ "timing facility" 1 to: 1000 do: [:index | y := 3.14 * index]]. "b := (x <= Time now)." "comparison" '! ----- Method: TerseGuideHelp class>>transcript (in category 'pages') ----- transcript ^HelpTopic title: 'Transcript' contents: '"************************************************************************ * Transcript: * ************************************************************************" Transcript clear. "clear to transcript window" Transcript show: ''Hello World''. "output string in transcript window" Transcript nextPutAll: ''Hello World''. "output string in transcript window" Transcript nextPut: $A. "output character in transcript window" Transcript space. "output space character in transcript window" Transcript tab. "output tab character in transcript window" Transcript cr. "carriage return / linefeed" ''Hello'' printOn: Transcript. "append print string into the window" ''Hello'' storeOn: Transcript. "append store string into the window" Transcript endEntry. "flush the output buffer" '!

1 0

Squeak 4.6: CommandLine-cmm.4.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of CommandLine to project Squeak 4.6: http://source.squeak.org/squeak46/CommandLine-cmm.4.mcz ==================== Summary ==================== Name: CommandLine-cmm.4 Author: cmm Time: 16 January 2015, 3:27:43.102 pm UUID: 0a2ab805-2910-49f5-81dc-c7de4581f4f6 Ancestors: CommandLine-fbs.3 Let Errors print themselves. ==================== Snapshot ==================== SystemOrganization addCategory: #'CommandLine-Tools'! SystemOrganization addCategory: #'CommandLine-UIManager'! UIManager subclass: #DummyUIManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CommandLine-UIManager'! !DummyUIManager commentStamp: 'fbs 10/31/2013 07:36' prior: 0! I'm an alternative UIManager used to run an the image without GUI. I redefine methods which require user input as these requests are irrelevant in a headless environment. ! ----- Method: DummyUIManager>>checkForNewDisplaySize (in category 'display') ----- checkForNewDisplaySize Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. DisplayScreen startUp. ! ----- Method: DummyUIManager>>chooseDirectory:from: (in category 'ui requests') ----- chooseDirectory: label from: dir ^ nil! ----- Method: DummyUIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray title: aString ^ aList first! ----- Method: DummyUIManager>>chooseFrom:values:lines:title: (in category 'ui requests') ----- chooseFrom: labelList values: valueList lines: linesArray title: aString ^ valueList first! ----- Method: DummyUIManager>>confirm: (in category 'ui requests') ----- confirm: queryString (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer|^answer]. self error: 'No user response possible'! ----- Method: DummyUIManager>>confirm:orCancel: (in category 'ui requests') ----- confirm: aString orCancel: cancelBlock (ProvideAnswerNotification signal: aString) ifNotNil: [:answer | ^answer == #cancel ifTrue: [cancelBlock value] ifFalse: [answer]]. self error: 'No user response possible'! ----- Method: DummyUIManager>>displayProgress:at:from:to:during: (in category 'ui requests') ----- displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock ^ workBlock value: Association new! ----- Method: DummyUIManager>>edit:label:accept: (in category 'ui requests') ----- edit: aText label: labelString accept: anAction ^ nil! ----- Method: DummyUIManager>>fontFromUser: (in category 'ui requests') ----- fontFromUser: priorFont self error: 'No user response possible'! ----- Method: DummyUIManager>>inform: (in category 'ui requests') ----- inform: aString "Nothing to be done here"! ----- Method: DummyUIManager>>informUserDuring: (in category 'ui requests') ----- informUserDuring: aBlock aBlock value: nil! ----- Method: DummyUIManager>>newDisplayDepthNoRestore: (in category 'display') ----- newDisplayDepthNoRestore: pixelSize "Change depths. Check if there is enough space!! , di" | area need | pixelSize = Display depth ifTrue: [^ self "no change"]. pixelSize abs < Display depth ifFalse: ["Make sure there is enough space" area := Display boundingBox area. "pixels" need := (area * (pixelSize abs - Display depth) // 8) "new bytes needed" + Smalltalk lowSpaceThreshold. (Smalltalk garbageCollectMost <= need and: [Smalltalk garbageCollect <= need]) ifTrue: [self error: 'Insufficient free space']]. Display setExtent: Display extent depth: pixelSize. DisplayScreen startUp! ----- Method: DummyUIManager>>request:initialAnswer: (in category 'ui requests') ----- request: queryString initialAnswer: defaultAnswer (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^ answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. self error: 'No user response possible'! ----- Method: DummyUIManager>>requestPassword: (in category 'ui requests') ----- requestPassword: queryString ^ self request: queryString initialAnswer: ''! ----- Method: DummyUIManager>>restoreDisplay (in category 'display') ----- restoreDisplay! ----- Method: DummyUIManager>>restoreDisplayAfter: (in category 'display') ----- restoreDisplayAfter: aBlock aBlock value. Sensor waitButton.! StandardToolSet subclass: #CommandLineToolSet instanceVariableNames: '' classVariableNames: 'SaveSnapshotOnError' poolDictionaries: '' category: 'CommandLine-Tools'! ----- Method: CommandLineToolSet class>>debugContext:label:contents: (in category 'debugging') ----- debugContext: aContext label: aString contents: contents "We can't open a command line debugger, so just log the error and carry on." | s | s := FileStream stderr. s nextPutAll: self className; nextPutAll: ': '; nextPutAll: aString; cr; nextPutAll: contents; cr. (aContext stackOfSize: 20) do: [:ctx | ctx printOn: s. s cr]. s flush.! ----- Method: CommandLineToolSet class>>debugError: (in category 'debugging') ----- debugError: anError "Print out a sensible stack trace and bail" self saveSnapshotOnError ifTrue: [ Smalltalk saveAs: 'Debug-' , Smalltalk imageEntry name ]. anError printVerboseOn: FileStream stderr. FileStream stderr flush. Smalltalk snapshot: false andQuit: true! ----- Method: CommandLineToolSet class>>debugSyntaxError: (in category 'debugging') ----- debugSyntaxError: anError FileStream stderr nextPutAll: '----- Syntax error -----' ; cr ; nextPutAll: anError errorCode ; cr ; nextPutAll: '----- Syntax error -----' ; cr ; flush. self debugError: anError! ----- Method: CommandLineToolSet class>>saveSnapshotOnError (in category 'preferences') ----- saveSnapshotOnError <preference: 'Save snapshot of image on failure' category: 'debug' description: 'If true, saves a snapshot of the failing image to the current directory.' type: #Boolean> ^ SaveSnapshotOnError ifNil: [SaveSnapshotOnError := false].! ----- Method: CommandLineToolSet class>>saveSnapshotOnError: (in category 'preferences') ----- saveSnapshotOnError: aBoolean SaveSnapshotOnError := aBoolean.! ----- Method: CommandLineToolSet class>>unload (in category 'class initialization') ----- unload ToolSet unregister: self.!

1 0

Squeak 4.6: SqueakSSL-Core-ul.29.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SqueakSSL-Core to project Squeak 4.6: http://source.squeak.org/squeak46/SqueakSSL-Core-ul.29.mcz ==================== Summary ==================== Name: SqueakSSL-Core-ul.29 Author: ul Time: 16 October 2014, 10:36:36.902 am UUID: e50d2a4f-cf16-4cdf-9ced-0d7471e550c6 Ancestors: SqueakSSL-Core-ul.28 Made #serverName: backwards compatible, by ignoring the primitive failure, when the plugin doesn't support it. ==================== Snapshot ==================== SystemOrganization addCategory: #'SqueakSSL-Core'! SocketStream subclass: #SecureSocketStream instanceVariableNames: 'ssl sendBuf readBuf decoded certIssues' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! !SecureSocketStream commentStamp: 'ar 7/25/2010 14:19' prior: 0! A variant on SocketStream supporting SSL/TLS encryption via SqueakSSL. ! ----- Method: SecureSocketStream>>ascii (in category 'accessing') ----- ascii "Switch to ASCII" super ascii. decoded := (ReadStream on: decoded originalContents asString from: 1 to: decoded size) position: decoded position; yourself. ! ----- Method: SecureSocketStream>>atEnd (in category 'private-compat') ----- atEnd "Pre Squeak 4.2 compatibility" self receiveAvailableData. ^super atEnd! ----- Method: SecureSocketStream>>binary (in category 'accessing') ----- binary "Switch to binary" super binary. decoded := (ReadStream on: decoded originalContents asByteArray from: 1 to: decoded size) position: decoded position; yourself. ! ----- Method: SecureSocketStream>>certError:code: (in category 'errors') ----- certError: errorString code: reason "Signal an issue with a certificate. If the reason code matches the acceptable cert issues, continue, otherwise signal an error." (certIssues allMask: reason) ifTrue:[^self]. ^SqueakSSLCertificateError signal: errorString, '(code: ', reason, ')'. ! ----- Method: SecureSocketStream>>certState (in category 'accessing') ----- certState "Returns the certificate verification bits. The returned value indicates whether the certificate is valid. The two standard values are: 0 - The certificate is valid. -1 - No certificate has been provided by the peer. Otherwise, the result is a bit mask of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " ^ssl ifNotNil:[ssl certState]! ----- Method: SecureSocketStream>>close (in category 'initialize') ----- close "Flush any data still not sent and take care of the socket." super close. ssl ifNotNil:[ ssl destroy. ssl := nil. ].! ----- Method: SecureSocketStream>>destroy (in category 'initialize') ----- destroy "Destroy the receiver and its underlying socket. Does not attempt to flush the output buffers. For a graceful close use SocketStream>>close instead." "Pre-4.2 compatibility. Should be 'super destroy' instead of 'socket destroy'" socket ifNotNil:[ socket destroy. socket := nil. ]. ssl ifNotNil:[ ssl destroy. ssl := nil. ].! ----- Method: SecureSocketStream>>flush (in category 'private-compat') ----- flush "Pre-Squeak 4.2 compatibility" ((outNextToWrite > 1) and: [socket isOtherEndClosed not]) ifTrue: [ [self sendData: outBuffer count: outNextToWrite - 1] on: ConnectionTimedOut do: [:ex | shouldSignal ifFalse: ["swallow"]]. outNextToWrite := 1] ! ----- Method: SecureSocketStream>>ignoredCertIssues (in category 'accessing') ----- ignoredCertIssues "Answer the mask of 'acceptable issues' with certs. To completely ignore all cert issues use -1 which still ensures privacy (encryption) to the remote host, but does not guard against a man-in-the-middle attack (i.e., you cannot be sure that the remote host is what he says he is). The reasons are a bit mask consisting of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " ^certIssues! ----- Method: SecureSocketStream>>ignoredCertIssues: (in category 'accessing') ----- ignoredCertIssues: reasonsMask "Set the mask of 'acceptable issues' with certs. To completely ignore all cert issues use -1 which still ensures privacy (encryption) to the remote host, but does not guard against a man-in-the-middle attack (i.e., you cannot be sure that the remote host is what he says he is). The reasons are a bit mask consisting of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " certIssues := reasonsMask! ----- Method: SecureSocketStream>>initialize (in category 'initialize') ----- initialize "Initialize the receiver" "I think 16k is the max for SSL frames so use a tad more" decoded := ReadStream on: (ByteArray new: 20000) from: 1 to: 0. super initialize. sendBuf := ByteArray new: 4096. readBuf := ByteArray new: 4096. certIssues := 0. ! ----- Method: SecureSocketStream>>isDataAvailable (in category 'private-compat') ----- isDataAvailable "Pre Squeak 4.2 compatibility" self isInBufferEmpty ifFalse: [^true]. ^self receiveAvailableData < inNextToWrite ! ----- Method: SecureSocketStream>>nextPutAllFlush: (in category 'private-compat') ----- nextPutAllFlush: aCollection "Pre Squeak 4.2 compatibility" | toPut | toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString]. self flush. "first flush pending stuff, then directly send" socket isOtherEndClosed ifFalse: [ [self sendData: toPut count: toPut size] on: ConnectionTimedOut do: [:ex | shouldSignal ifFalse: ["swallow"]]] ! ----- Method: SecureSocketStream>>peerName (in category 'accessing') ----- peerName "Returns the certificate name of the remote peer. The method only returns a name if the certificate has been verified." ^ssl ifNotNil:[ssl peerName]! ----- Method: SecureSocketStream>>receiveAvailableData (in category 'private-compat') ----- receiveAvailableData "Pre Squeak 4.2 compatibility" recentlyRead := self receiveDataInto: inBuffer startingAt: inNextToWrite. ^self adjustInBuffer: recentlyRead ! ----- Method: SecureSocketStream>>receiveData (in category 'private-socket') ----- receiveData "This method drains the available decryption data before waiting for the socket" | pos | "Note: The loop here is necessary to catch cases where a TLS packet is split among TCP packets. In this case we would pull the first portion of the TLS packet here but receiveAvailableData would return nothing since the contents of the packet can't be decoded until the rest has come in." [pos := inNextToWrite. self receiveAvailableData. pos = inNextToWrite ifFalse:[^pos]. "Pre-4.2 compatibility; should be 'super receiveData' instead." socket waitForDataFor: self timeout ifClosed: [self shouldSignal ifTrue:[ConnectionClosed signal: 'Connection closed while waiting for data.']] ifTimedOut: [self shouldTimeout ifTrue:[ConnectionTimedOut signal: 'Data receive timed out.']]. self isConnected] whileTrue. "Final attempt to read data if a non-signaling connection closes" ^self receiveAvailableData. ! ----- Method: SecureSocketStream>>receiveData: (in category 'private-compat') ----- receiveData: nBytes "Pre Squeak 4.2 compatibility" self receiveAvailableData. ^super receiveData: nBytes.! ----- Method: SecureSocketStream>>receiveDataIfAvailable (in category 'private-compat') ----- receiveDataIfAvailable "Pre Squeak 4.2 compatibility" ^self receiveAvailableData ! ----- Method: SecureSocketStream>>receiveDataInto:startingAt: (in category 'private-socket') ----- receiveDataInto: buffer startingAt: index "Read and decrypt the data from the underlying socket. " | count bytesRead | "While in handshake, use the superclass version" ssl ifNil:[ "Pre-4.2 compatibility; should be 'super receiveDataInto: buffer startingAt: index'" ^socket receiveAvailableDataInto: buffer startingAt: index. ]. "Only decode more data if all the decoded contents has been drained" decoded atEnd ifTrue:[ "Decrypt more data if available" bytesRead := 0. [count := ssl decrypt: readBuf from: 1 to: bytesRead into: decoded originalContents. count < 0 ifTrue:[^self error: 'SSL error, code: ', count]. bytesRead := 0. count = 0 ifTrue:[ bytesRead := socket receiveAvailableDataInto: readBuf startingAt: 1. ]. bytesRead = 0] whileFalse. "Update for number of bytes decoded" decoded setFrom: 1 to: count. ]. "Push data from decoded into the result buffer" count := (decoded size - decoded position) min: (buffer size - index + 1). (decoded next: count into: buffer startingAt: index) size < count ifTrue:[^self error: 'Unexpected read failure']. ^count ! ----- Method: SecureSocketStream>>sendData:count: (in category 'private-socket') ----- sendData: buffer count: n "Encrypts the data before sending it on the underlying socket. Breaks large chunks into 2k components to fit safely into ssl frame." | remain start amount count | "While in handshake, use the superclass version" ssl ifNil:[ "Pre-4.2 compatibility; should be 'super sendData: buffer count: n' instead" ^socket sendData: buffer count: n ]. "Break the input into reasonable chunks and send them" remain := n. start := 1. [remain > 0] whileTrue:[ amount := remain min: 2048. count := ssl encrypt: buffer from: start to: start+amount-1 into: sendBuf. socket sendData: sendBuf count: count. remain := remain - amount. start := start + amount. ].! ----- Method: SecureSocketStream>>ssl (in category 'accessing') ----- ssl "The SqueakSSL instance" ^ssl! ----- Method: SecureSocketStream>>sslAccept: (in category 'initialize') ----- sslAccept: certName "Perform the SSL server handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." | squeakSSL result inbuf | inbuf := ''. squeakSSL := SqueakSSL new. squeakSSL certName: certName. "Perform the server handshake" [[squeakSSL isConnected] whileFalse:[ "Read input" self receiveData. inbuf := self nextAvailable. result := squeakSSL accept: inbuf from: 1 to: inbuf size into: sendBuf. "Check for errors first" result < -1 ifTrue:[^self error: 'SSL accept failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[ self nextPutAll: (sendBuf copyFrom: 1 to: result). self flush. ]. ]. "There should be no pending data at this point, ensure it is so. XXXX: If you ever see this problem, please inform me." self isInBufferEmpty ifFalse:[self error: 'Unexpected input data']. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! ----- Method: SecureSocketStream>>sslConnect (in category 'initialize') ----- sslConnect "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." self sslConnectTo: nil! ----- Method: SecureSocketStream>>sslConnectTo: (in category 'initialize') ----- sslConnectTo: serverName "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete. If serverName is not nil, then try to use it for SNI." | inbuf squeakSSL result | inbuf := ''. squeakSSL := SqueakSSL new. serverName ifNotNil: [ squeakSSL serverName: serverName ]. "Perform the SSL handshake" [[result := squeakSSL connect: inbuf from: 1 to: inbuf size into: sendBuf. result = 0] whileFalse:[ "Check for errors first" result < -1 ifTrue:[^self error: 'SSL connect failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[ self nextPutAll: (sendBuf copyFrom: 1 to: result). self flush. ]. "Read more input and repeat" self receiveData. inbuf := self nextAvailable. ]. "There should be no pending data at this point, ensure it is so. XXXX: If you ever see this problem, please inform me." self isInBufferEmpty ifFalse:[self error: 'Unexpected input data']. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! ----- Method: SecureSocketStream>>upToAll: (in category 'private-compat') ----- upToAll: aStringOrByteArray "Pre Squeak 4.2 compatibility" ^self upToAll: aStringOrByteArray limit: 100000! ----- Method: SecureSocketStream>>upToAll:limit: (in category 'private-compat') ----- upToAll: aStringOrByteArray limit: nBytes "Pre Squeak 4.2 compatibility" | index sz result searchedSoFar target | "Deal with ascii vs. binary" self isBinary ifTrue:[target := aStringOrByteArray asByteArray] ifFalse:[target := aStringOrByteArray asString]. sz := target size. "Look in the current inBuffer first" index := inBuffer indexOfSubCollection: target startingAt: lastRead - sz + 2. (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" result := self nextInBuffer: index - lastRead - 1. self skip: sz. ^ result ]. [searchedSoFar := self inBufferSize. "Receive more data" self receiveData. recentlyRead > 0] whileTrue:[ "Data begins at lastRead + 1, we add searchedSoFar as offset and backs up sz - 1 so that we can catch any borderline hits." index := inBuffer indexOfSubCollection: target startingAt: (lastRead + searchedSoFar - sz + 2 max: 1). (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" result := self nextInBuffer: index - lastRead - 1. self skip: sz. ^ result ]. "Check if we've exceeded the max. amount" (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) ifTrue:[^self nextAllInBuffer]. ]. "not found and (non-signaling) connection was closed" ^self nextAllInBuffer! ----- Method: SecureSocketStream>>verifyCert: (in category 'initialize') ----- verifyCert: hostName "Verifies the cert state and host name" | certFlags | certFlags := self certState. certFlags = -1 ifTrue:[^self certError: 'No certificate was provided' code: -1]. certFlags = 0 ifFalse:[self certError: 'Invalid certificate' code: certFlags]. (ssl peerName match: hostName) ifFalse:[self certError: 'Host name mismatch' code: -1].! Socket subclass: #SecureSocket instanceVariableNames: 'ssl decoded readBuf sendBuf' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! ----- Method: SecureSocket class>>google: (in category 'examples') ----- google: query "An example HTTPS query to encrypted.google.com. Example: SecureSocket google: 'squeak'. SecureSocket google: 'SqueakSSL'. " | hostName address socket | "Change the host name to try an https request to some other host" hostName := 'encrypted.google.com'.. address := NetNameResolver addressForName: hostName. socket := SecureSocket newTCP. "Connect the TCP socket" socket connectTo: address port: 443. socket waitForConnectionFor: 10. ["Handle the client handshake" socket sslConnectTo: hostName. "Verify that the cert is valid" socket certState = 0 ifFalse:[ self error: 'The certificate is invalid (code: ', socket certState,')'. ]. "If the certificate is valid, make sure we're were we wanted to go" (socket peerName match: hostName) ifFalse:[ self error: 'Host name mismatch: ', socket peerName. ]. "Send encrypted data" socket sendData: 'GET /search?q=', query,' HTTP/1.0', String crlf, 'Host: ', hostName, String crlf, 'Connection: close', String crlf, String crlf. "Wait for the response" ^String streamContents:[:s| [[true] whileTrue:[s nextPutAll: socket receiveData]] on: ConnectionClosed, ConnectionTimedOut do:[:ex| ex return]. ]] ensure:[socket destroy]. ! ----- Method: SecureSocket>>accept (in category 'connect') ----- accept "Accept a connection from the receiver socket. Return a new socket that is connected to the client" ^self class acceptFrom: self.! ----- Method: SecureSocket>>certState (in category 'accessing') ----- certState ^ssl ifNotNil:[ssl certState]! ----- Method: SecureSocket>>decodeData (in category 'primitives') ----- decodeData "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available." | total bytesRead | decoded atEnd ifFalse:[^self]. "Decrypt more data if available" bytesRead := 0. [total := ssl decrypt: readBuf from: 1 to: bytesRead into: decoded originalContents. total < 0 ifTrue:[^self error: 'SSL error, code: ', total]. bytesRead := 0. total = 0 ifTrue:[ bytesRead := super primSocket: socketHandle receiveDataInto: readBuf startingAt: 1 count: readBuf size. ]. bytesRead = 0] whileFalse. "Update for number of bytes decoded" decoded setFrom: 1 to: total. ! ----- Method: SecureSocket>>destroy (in category 'initialize') ----- destroy ssl ifNotNil:[ ssl destroy. ssl := nil ]. super destroy.! ----- Method: SecureSocket>>initialize (in category 'initialize') ----- initialize super initialize. decoded := ReadStream on: (ByteArray new: 20000) from: 1 to: 0. sendBuf := ByteArray new: 4096. readBuf := ByteArray new: 4096. ! ----- Method: SecureSocket>>isConnected (in category 'primitives') ----- isConnected "Return true if this socket is connected." "We mustn't return false if there is data available" ^super isConnected or:[self dataAvailable]! ----- Method: SecureSocket>>peerName (in category 'accessing') ----- peerName ^ssl ifNotNil:[ssl peerName]! ----- Method: SecureSocket>>primSocket:receiveDataInto:startingAt:count: (in category 'primitives') ----- primSocket: socketID receiveDataInto: buffer startingAt: index count: count "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available." | total | ssl ifNil:[^super primSocket: socketID receiveDataInto: buffer startingAt: index count: count]. self decodeData. "Push data from decoded into the result buffer" total := (decoded size - decoded position) min: (buffer size - index + 1). (decoded readInto: buffer startingAt: index count: total) = total ifFalse:[self error: 'Unexpected read failure']. ^total ! ----- Method: SecureSocket>>primSocket:sendData:startIndex:count: (in category 'primitives') ----- primSocket: socketID sendData: buffer startIndex: start count: amount "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed." "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created." | count | ssl ifNil:[^super primSocket: socketID sendData: buffer startIndex: start count: amount]. count := ssl encrypt: buffer from: start to: start+amount-1 into: sendBuf. count < 0 ifTrue:[self error: 'SSL Error: ', count]. ^super primSocket: socketID sendData: sendBuf startIndex: 1 count: count! ----- Method: SecureSocket>>primSocketReceiveDataAvailable: (in category 'primitives') ----- primSocketReceiveDataAvailable: socketID "Return true if data may be available for reading from the current socket." ssl ifNil:[^super primSocketReceiveDataAvailable: socketID]. self decodeData. ^decoded atEnd not! ----- Method: SecureSocket>>ssl (in category 'accessing') ----- ssl "Answer the SqueakSSL instance" ^ssl! ----- Method: SecureSocket>>sslAccept: (in category 'connect') ----- sslAccept: certName "Perform the SSL server handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." | squeakSSL result inbuf | inbuf := ''. squeakSSL := SqueakSSL new. squeakSSL certName: certName. "Perform the server handshake" [[squeakSSL isConnected] whileFalse:[ "Read input" inbuf := self receiveData. result := squeakSSL accept: inbuf from: 1 to: inbuf size into: sendBuf. "Check for errors first" result < -1 ifTrue:[^self error: 'SSL accept failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self sendData: (sendBuf copyFrom: 1 to: result)]. ]. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! ----- Method: SecureSocket>>sslConnect (in category 'connect') ----- sslConnect "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." self sslConnectTo: nil! ----- Method: SecureSocket>>sslConnectTo: (in category 'connect') ----- sslConnectTo: serverName "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete. If serverName is not nil, then try to use it for SNI." | inbuf squeakSSL result | inbuf := ''. squeakSSL := SqueakSSL new. serverName ifNotNil: [ squeakSSL serverName: serverName ]. "Perform the SSL handshake" [[result := squeakSSL connect: inbuf from: 1 to: inbuf size into: sendBuf. result = 0] whileFalse:[ "Check for errors first" result < -1 ifTrue:[^self error: 'SSL connect failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self sendData: (sendBuf copyFrom: 1 to: result)]. "Read more input and repeat" inbuf := self receiveData. ]. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! Error subclass: #SqueakSSLCertificateError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! ----- Method: SqueakSSLCertificateError>>isResumable (in category 'testing') ----- isResumable "Determine whether an exception is resumable." ^true! Object subclass: #SqueakSSL instanceVariableNames: 'handle readBlock writeBlock' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! !SqueakSSL commentStamp: 'ar 7/16/2010 23:14' prior: 0! SqueakSSL provides an interface to the platforms SSL/TLS facilities. ! ----- Method: SqueakSSL class>>checkCert: (in category 'utilities') ----- checkCert: certName "Attempt to verify the cert with the given name by performing an SSL handshake. Raises an error if there is an issue with the cert, returns the peer name from the cert if successful." | sslClient sslServer inbuf outbuf result | inbuf := ByteArray new: 4096. outbuf := ByteArray new: 4096. ["Perform the SSL handshake" sslClient := SqueakSSL new. sslServer := SqueakSSL new. sslServer certName: certName. result := 0. [result := sslClient connect: inbuf from: 1 to: result into: outbuf. result = 0] whileFalse:[ result < -1 ifTrue:[^self error: 'SSL handshake failed (client code: ', result, ')']. result := sslServer accept: outbuf from: 1 to: result into: inbuf. result < -1 ifTrue:[^self error: 'SSL handshake failed (server code: ', result, ')']. ]. "Handshake complete. Check the cert status" sslClient certState = 0 ifFalse:[ ^self error: 'Certificate validation failed (code: ', sslClient certState, ')'. ]. "When successful, just return the peer name to the caller" ^sslClient peerName ] ensure:[ sslClient ifNotNil:[sslClient destroy]. sslServer ifNotNil:[sslServer destroy]. ].! ----- Method: SqueakSSL class>>ensureSampleCert (in category 'examples') ----- ensureSampleCert "Ensure that we have a sample certificate for the tests" SqueakSSL platformName caseOf: { ['unix'] -> [^self ensureSampleCertFile]. ['Win32'] -> [^self ensureSampleCertInStore]. } otherwise: [^nil]. ! ----- Method: SqueakSSL class>>ensureSampleCertFile (in category 'examples') ----- ensureSampleCertFile "On Unix, we can simply create a valid cert file" | certName file | SqueakSSL platformName = 'unix' ifFalse:[^self]. certName := self name, 'Cert.pem'. (FileDirectory default fileExists: certName) ifFalse:[ file := FileDirectory default newFileNamed: certName. [file nextPutAll: self exampleCertFile withUnixLineEndings] ensure:[file close]. ]. ^FileDirectory default fullNameFor: certName. ! ----- Method: SqueakSSL class>>ensureSampleCertInStore (in category 'examples') ----- ensureSampleCertInStore "Ensure that we have a valid certificate in the Windows certificate store" SqueakSSL platformName = 'Win32' ifFalse:[^self]. "Undocumented. Allows importing a pfx w/o password. For the sole purpose of being able to run tests reliably" SqueakSSL new setStringProperty: 10001 to: self exampleCertPFX. ^'testcert'. "Friendly name of test cert" ! ----- Method: SqueakSSL class>>exampleCertFile (in category 'examples') ----- exampleCertFile ^'-----BEGIN RSA PRIVATE KEY----- MIICXQIBAAKBgQDnCv/gxDCb2yq15qkNwYtdMOHfW609Ck7wfwjVgzSNg+Hw+1R4 +krWhYRsWoXZUcy9xPC9WhnFCFijcnROcWp7vByVukFkVPYgzk1OBFT484ZCLBme 08GqLSzZrjgu7c1Yu5M9MZQdZKObBvZzDFsnvFccfM7G5mX/FgATasYaLQIDAQAB AoGBAMpUJ6B+LtNOKykAxir1w0Xo+OTRM/SwglC57tKMBAmp5MNUVbVb+w3B/yWk YHLf35yQSwKHVOnnVThNkuzfBY+MBxnaZwCByKknB4viP1ihPmfwdtqW4QXt1CTH 53sc9BVPjs3Nn1eEVrc582RK0MhORmjvlz+GkTswXCiKD3tBAkEA+6/au8T8XUeM y/KrtJ+U84seviw5nY93Yg7495n4ir1fojp4wFbWq1JTeM22zspZQOKzEsjxfHUi UH3buH//OwJBAOsAlJdIZqTIJponBXho+jqLHqcZYXBz3znDzHZU1PLfyfq2DuVe gt8UWa4VwlCZNtPi7g/iFPEcLOlf2XY3hbcCQFU7voVsNlKYknPW4JMwn87CREz+ yRw0o6dPjry7JdJGQ4a66n2oatZl8OKuN8Rb/lHc8+vepPkS6eX8WVZn8lUCQE2r F3EYgLQdYoS4ONqe93S53hukC8w6v6A70iuZxfevdvXhjfLI1cAc3bbngh1ZRgGp kry1H+7APSe0gg7MMukCQQD3jdsVoc4yhziMdpUMyw6R6vYCMJbMEr/tI6CJYBG4 lW+zdcLK2d6GNpZU80F49HOvxH4HMg1Qv+UUiuxT7jpG -----END RSA PRIVATE KEY----- -----BEGIN CERTIFICATE----- MIICxTCCAi6gAwIBAgIJAN/0HUpkM5dvMA0GCSqGSIb3DQEBBQUAMEwxCzAJBgNV BAYTAkdCMRIwEAYDVQQIEwlCZXJrc2hpcmUxEDAOBgNVBAcTB05ld2J1cnkxFzAV BgNVBAoTDk15IENvbXBhbnkgTHRkMB4XDTExMDYwNjE0MzcyMFoXDTEyMDYwNTE0 MzcyMFowTDELMAkGA1UEBhMCR0IxEjAQBgNVBAgTCUJlcmtzaGlyZTEQMA4GA1UE BxMHTmV3YnVyeTEXMBUGA1UEChMOTXkgQ29tcGFueSBMdGQwgZ8wDQYJKoZIhvcN AQEBBQADgY0AMIGJAoGBAOcK/+DEMJvbKrXmqQ3Bi10w4d9brT0KTvB/CNWDNI2D 4fD7VHj6StaFhGxahdlRzL3E8L1aGcUIWKNydE5xanu8HJW6QWRU9iDOTU4EVPjz hkIsGZ7TwaotLNmuOC7tzVi7kz0xlB1ko5sG9nMMWye8Vxx8zsbmZf8WABNqxhot AgMBAAGjga4wgaswHQYDVR0OBBYEFGFwXmx2B6FB25yKMBm6g884lB2xMHwGA1Ud IwR1MHOAFGFwXmx2B6FB25yKMBm6g884lB2xoVCkTjBMMQswCQYDVQQGEwJHQjES MBAGA1UECBMJQmVya3NoaXJlMRAwDgYDVQQHEwdOZXdidXJ5MRcwFQYDVQQKEw5N eSBDb21wYW55IEx0ZIIJAN/0HUpkM5dvMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcN AQEFBQADgYEAbjMF7YzNQGovKD4NRjsnnKzQnUCTw6UquY2Oz/5SeLcPfLm8DudF qppAjJjNpAgYC0yWoWcIxatYF/AsgGc2WL3hzI8oK7by6STfVi5RfLA6jS7lIDOv 4BUVsWZKADbEPsfiwed9b9MLLx8gpLLBrrr2rZpSyeDu4v16haV6wg8= -----END CERTIFICATE----- '! ----- Method: SqueakSSL class>>exampleCertPFX (in category 'examples') ----- exampleCertPFX ^ #[48 130 7 50 2 1 3 48 130 6 248 6 9 42 134 72 134 247 13 1 7 1 160 130 6 233 4 130 6 229 48 130 6 225 48 130 3 191 6 9 42 134 72 134 247 13 1 7 6 160 130 3 176 48 130 3 172 2 1 0 48 130 3 165 6 9 42 134 72 134 247 13 1 7 1 48 28 6 10 42 134 72 134 247 13 1 12 1 6 48 14 4 8 88 63 142 234 51 170 181 1 2 2 8 0 128 130 3 120 247 113 35 203 188 93 48 77 162 13 174 138 246 211 61 198 135 133 35 173 48 145 17 17 215 165 194 254 211 158 248 98 76 208 35 117 179 66 160 245 118 213 71 174 220 87 29 165 94 87 52 172 173 229 251 165 205 43 242 114 250 65 123 9 113 132 130 241 182 211 44 155 163 177 90 52 4 72 47 37 0 101 149 229 33 113 144 29 160 38 44 28 178 1 193 134 122 194 233 165 233 236 242 121 119 47 72 143 91 146 148 29 155 94 202 17 124 77 21 110 194 197 228 149 28 9 129 74 139 76 1 180 245 235 1 191 177 175 158 159 16 12 52 96 80 243 34 26 155 45 210 192 183 217 230 122 13 19 197 214 172 29 151 24 153 136 8 203 72 220 199 79 22 79 251 248 83 204 246 117 242 216 219 53 20 182 121 148 173 221 177 210 171 107 56 101 159 63 110 23 37 168 47 25 252 163 244 206 125 220 122 108 251 223 93 219 129 242 137 229 199 216 254 230 235 62 33 236 39 211 255 184 37 134 152 51 188 182 195 242 18 43 29 134 16 183 48 35 0 100 231 121 145 91 99 171 183 225 246 126 56 190 198 188 79 227 107 211 1 65 113 64 71 9 120 185 75 138 171 220 155 182 35 226 180 121 108 83 253 1 232 183 151 97 160 73 117 218 140 182 224 58 227 40 171 59 143 213 187 41 57 174 185 115 190 81 111 110 81 149 122 114 170 14 10 168 113 248 120 13 247 231 160 162 14 4 227 41 48 249 153 2 107 130 176 16 144 160 116 41 25 241 225 126 110 24 7 69 221 205 108 141 73 164 61 76 219 248 94 142 69 171 109 44 45 75 34 179 205 40 62 161 191 222 79 131 239 230 86 201 124 48 226 212 13 178 187 248 29 191 81 98 229 199 91 204 153 220 112 227 71 116 233 131 134 160 244 78 77 84 128 144 63 123 210 148 221 133 201 44 41 218 89 64 253 172 106 220 127 130 151 11 88 155 57 172 192 196 165 93 177 197 139 128 45 223 88 64 196 6 15 153 160 156 168 3 202 102 129 134 25 75 61 51 190 216 218 178 101 250 91 255 169 245 170 55 228 47 111 197 10 145 196 180 96 217 97 49 104 134 62 228 86 203 242 207 75 246 77 115 20 81 40 173 107 113 251 9 172 18 21 10 102 117 86 63 252 91 190 64 190 140 1 146 70 75 130 110 94 129 107 155 24 253 117 204 162 32 30 102 75 62 42 204 19 159 205 62 23 26 192 23 79 128 205 18 72 198 84 83 107 16 234 121 61 33 101 48 72 32 197 119 216 2 24 213 8 133 63 181 65 15 192 138 240 203 219 69 207 68 66 233 168 195 13 212 235 34 22 142 226 141 25 131 250 123 202 13 163 142 214 170 179 240 5 21 201 143 103 4 70 139 84 104 115 140 248 163 15 71 220 197 222 251 170 15 158 82 26 214 186 154 139 37 245 77 174 37 29 218 103 99 14 230 36 75 72 140 186 89 146 99 10 10 94 68 150 159 234 64 234 32 254 117 187 160 102 46 25 25 77 184 134 151 2 236 109 63 58 186 148 239 251 122 59 123 200 29 42 70 51 118 54 71 184 71 0 111 178 10 81 141 247 59 254 67 191 214 239 78 238 217 142 184 87 107 111 14 102 97 61 229 94 118 187 52 204 25 52 233 177 250 17 62 113 22 163 2 250 13 5 238 103 80 143 201 25 73 33 93 212 81 126 207 29 138 72 191 60 182 132 255 76 97 254 188 96 81 72 73 43 118 191 106 118 41 112 45 96 255 148 59 79 111 89 61 199 106 75 199 154 21 60 25 124 156 168 42 233 7 102 203 120 161 126 125 118 110 114 229 174 26 31 215 140 120 85 171 146 207 176 159 100 102 215 83 142 39 61 255 84 12 19 235 207 44 199 229 220 98 38 167 113 24 88 66 31 115 135 184 70 133 129 3 57 44 202 230 225 37 70 222 228 126 130 216 185 247 48 130 3 26 6 9 42 134 72 134 247 13 1 7 1 160 130 3 11 4 130 3 7 48 130 3 3 48 130 2 255 6 11 42 134 72 134 247 13 1 12 10 1 2 160 130 2 166 48 130 2 162 48 28 6 10 42 134 72 134 247 13 1 12 1 3 48 14 4 8 157 82 4 247 110 231 147 241 2 2 8 0 4 130 2 128 81 141 63 61 170 27 13 87 195 101 166 17 185 109 40 123 79 40 85 18 112 106 87 142 32 19 113 12 131 155 36 149 204 92 237 1 142 195 36 34 134 117 241 52 38 4 223 121 9 207 149 114 168 232 16 31 38 128 191 205 129 96 20 210 13 246 170 175 72 206 132 163 135 42 227 200 61 4 223 65 246 136 48 139 206 95 243 12 78 111 152 17 172 160 235 19 185 107 248 215 171 69 17 108 110 12 143 48 163 35 112 60 104 210 180 61 97 35 132 190 185 52 214 94 137 51 90 103 115 176 108 81 179 254 43 128 230 0 178 229 102 142 136 122 52 213 218 150 93 29 251 227 151 124 220 211 152 14 214 57 253 134 5 216 20 70 142 9 67 253 187 20 45 239 144 60 149 38 118 94 5 240 92 240 11 163 131 39 237 219 228 68 198 176 184 23 155 181 19 149 188 2 73 215 118 95 52 169 186 179 142 106 201 222 98 38 7 72 12 167 242 23 217 58 8 48 98 75 203 68 202 230 50 109 112 231 34 77 8 212 132 34 53 120 195 211 170 209 138 45 25 22 249 200 39 170 102 104 35 23 165 199 0 180 149 231 66 55 227 101 212 227 111 140 202 218 21 211 142 227 95 228 34 59 29 23 212 43 142 132 36 100 19 58 38 124 136 77 192 186 174 111 82 162 61 13 207 31 123 138 16 236 169 94 182 156 137 71 11 3 223 81 146 185 230 164 108 87 82 126 167 121 216 202 201 21 197 50 204 62 46 30 80 245 60 157 124 81 50 79 225 144 130 55 141 182 176 61 62 128 88 105 3 206 168 97 81 180 145 20 211 135 252 195 71 185 42 209 139 98 27 47 3 181 252 89 41 67 246 238 34 71 224 211 65 165 130 115 138 102 130 153 126 248 225 200 42 33 247 34 83 47 161 223 179 49 244 240 108 184 244 229 129 42 34 208 77 62 142 125 57 121 39 2 223 123 75 83 35 184 136 71 228 58 15 61 16 21 111 21 72 84 107 99 66 51 251 47 132 92 62 85 53 197 90 170 118 254 28 232 170 69 119 55 25 30 210 189 113 231 121 214 151 141 218 11 54 90 17 40 94 143 41 72 221 16 204 7 126 200 220 28 157 75 159 142 181 56 44 244 2 206 93 230 121 110 124 181 108 157 161 2 131 121 119 22 99 4 194 228 137 124 193 89 196 239 216 79 206 88 233 84 70 205 120 107 79 1 95 117 198 73 112 207 18 52 174 188 81 59 75 238 227 184 57 166 66 12 188 200 97 251 40 146 239 27 44 6 104 216 90 153 8 161 189 194 32 200 124 180 43 124 169 200 80 238 28 234 114 46 216 243 192 75 180 149 181 215 39 214 64 69 183 205 159 252 238 50 141 132 214 2 245 5 251 219 32 217 37 146 78 226 201 81 209 79 74 174 108 65 49 70 48 31 6 9 42 134 72 134 247 13 1 9 20 49 18 30 16 0 116 0 101 0 115 0 116 0 99 0 101 0 114 0 116 48 35 6 9 42 134 72 134 247 13 1 9 21 49 22 4 20 161 19 18 59 76 168 198 72 97 179 205 74 244 65 111 116 223 140 145 154 48 49 48 33 48 9 6 5 43 14 3 2 26 5 0 4 20 182 216 177 70 221 73 183 142 238 169 97 22 175 148 97 145 207 223 75 54 4 8 178 120 42 60 194 226 96 245 2 2 8 0]! ----- Method: SqueakSSL class>>google: (in category 'examples') ----- google: query "An example HTTPS query to encrypted.google.com. Example: SqueakSSL google: 'squeak'. SqueakSSL google: 'SqueakSSL'. " | hostName address socket ssl | "Change the host name to try an https request to some other host" hostName := 'encrypted.google.com'.. address := NetNameResolver addressForName: hostName. socket := Socket newTCP. "Connect the TCP socket" socket connectTo: address port: 443. socket waitForConnectionFor: 10. "Set up SqueakSSL using the convenience APIs" ssl := SqueakSSL on: socket. ["Let SqueakSSL handle the client handshake" ssl connect. "Verify that the cert is valid" ssl certState = 0 ifFalse:[ self error: 'The certificate is invalid (code: ', ssl certState,')'. ]. "If the certificate is valid, make sure we're were we wanted to go" (ssl peerName match: hostName) ifFalse:[ self error: 'Host name mismatch: ', ssl peerName. ]. "Send encrypted data" ssl sendData: 'GET /search?q=', query,' HTTP/1.0', String crlf, 'Host: ', hostName, String crlf, 'Connection: close', String crlf, String crlf. "Wait for the response" ^String streamContents:[:s| [socket isConnected | socket dataAvailable] whileTrue:[s nextPutAll: ssl receiveData]]. ] ensure:[ssl destroy]. ! ----- Method: SqueakSSL class>>on: (in category 'instance creation') ----- on: aSocket "Convenience API. Create a SqueakSSL operating on a standard TCP socket. Generally not very useful for real applications (it lacks error handling etc) but very helpful for debugging and other experiments." ^self new on: aSocket! ----- Method: SqueakSSL class>>platformName (in category 'utilities') ----- platformName "Return the name of the platform we're running on." ^Smalltalk getSystemAttribute: 1001! ----- Method: SqueakSSL class>>secureSocket (in category 'instance creation') ----- secureSocket "Answer the class to use as secure socket implementation. Provided here so that users only need a dependency on SqueakSSL." ^SecureSocket! ----- Method: SqueakSSL class>>secureSocketStream (in category 'instance creation') ----- secureSocketStream "Answer the class to use as secure socket stream implementation. Provided here so that users only need a dependency on SqueakSSL." ^SecureSocketStream! ----- Method: SqueakSSL class>>serverOn:certName: (in category 'examples') ----- serverOn: port certName: certName "An HTTPS server example. Fires up a listener at the given port such that you can point a browser to that https url. Responds with a single line of text and closes the listener after the first connection. SqueakSSL serverOn: 8443 certName: 'Internet Widgits Pty'. SqueakSSL serverOn: 8443 certName: '/home/andreas/certs/testcert.pem'. " | listener socket ssl | "Set up the listener socket" listener := Socket newTCP. listener listenOn: port backlogSize: 8. [socket := listener waitForAcceptFor: 30. socket == nil] whileTrue. listener destroy. "Set up SqueakSSL for the just accepted connection" [ssl := SqueakSSL on: socket. "The SSL needs the cert name." ssl certName: certName. "Let SqueakSSL do the server handshake" ssl accept. "Read out the HTTPS request" ssl receiveData. "And send the response" ssl sendData: 'HTTP/1.0 200 OK', String crlf, 'Connection: close', String crlf, 'Content-Type: text/plain', String crlf, 'Server: SqueakSSL', String crlf, String crlf, 'This is a successful SqueakSSL response.'. socket close. ] ensure:[ ssl destroy. socket destroy. ].! ----- Method: SqueakSSL>>accept (in category 'convenience') ----- accept "Convenience API. Perform an SSL server handshake. Raises an error if something goes wrong." | inbuf outbuf count result | inbuf := ByteArray new: 4096. outbuf := ByteArray new: 4096. count := 0. [self isConnected] whileFalse:[ "Read input" count := self readDataInto: inbuf. result := self accept: inbuf from: 1 to: count into: outbuf. "Check for errors first" result < -1 ifTrue:[^self error: 'SSL accept failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self writeData: outbuf count: result]. ]. ! ----- Method: SqueakSSL>>accept:from:to:into: (in category 'operations') ----- accept: srcBuf from: start to: stop into: dstBuf "Start or continue the server handshake using the given input token." ^self primitiveSSL: handle accept: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>certName (in category 'accessing') ----- certName "The name of the (local) certificate to provide to the remote peer." ^self primitiveSSL: handle getStringProperty: 1! ----- Method: SqueakSSL>>certName: (in category 'accessing') ----- certName: aString "Sets the name of the (local) certificate to provide to the remote peer. OpenSSL: The name is the full path to a .pem file. WinSSL: The name is matched against the 'friendly name' of a certificate in the cert store. " ^self primitiveSSL: handle setStringProperty: 1 toValue: (aString ifNil:[''])! ----- Method: SqueakSSL>>certState (in category 'accessing') ----- certState "Returns the certificate verification bits. The returned value indicates whether the certificate is valid. The two standard values are: 0 - The certificate is valid. -1 - No certificate has been provided by the peer. Otherwise, the result is a bit mask of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " ^self primitiveSSL: handle getIntProperty: 3! ----- Method: SqueakSSL>>connect (in category 'convenience') ----- connect "Convenience API. Perform an SSL client handshake. Raises an error if something goes wrong." | inbuf outbuf count result | inbuf := ByteArray new: 4096. outbuf := ByteArray new: 4096. count := 0. "Begin the SSL handshake" [result := self connect: inbuf from: 1 to: count into: outbuf. result = 0] whileFalse:[ "Check for errors first" result < -1 ifTrue:[^self error: 'SSL connect failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self writeData: outbuf count: result]. "Read more input and repeat" count := self readDataInto: inbuf. ].! ----- Method: SqueakSSL>>connect:from:to:into: (in category 'operations') ----- connect: srcBuf from: start to: stop into: dstBuf "Start or continue the server handshake using the given input token." ^self primitiveSSL: handle connect: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>decrypt: (in category 'convenience') ----- decrypt: data "Convenience API. Decrypt incoming data and return the result. Warning: This method may produce more or less results than expected unless called with exactly one SSL/TLS frame." | buf count | buf := data class new: 4096. count := self decrypt: data from: 1 to: data size into: buf. count < 0 ifTrue:[self error: 'Decryption failed, code: ', count]. ^buf copyFrom: 1 to: count! ----- Method: SqueakSSL>>decrypt:from:to:into: (in category 'operations') ----- decrypt: srcBuf from: start to: stop into: dstBuf "Decrypt the input in srcBuf into the provided output buffer. Clients are expected to adhere to the following rules: * The size of dstBuf must be large enough for the largest encrypted packet. * Clients must not call this method with a huge srcBuf (tens of kb of data) * After having called this method with new input, clients must call it with NO input until all data has been 'drained' for example: count := squeakSSL decrypt: srcBuf into: dstBuf. [count > 0] whileTrue:[ count := squeakSSL decrypt: #[] into: dstBuf. ]. " ^self primitiveSSL: handle decrypt: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>destroy (in category 'initialize') ----- destroy "Destroys the underlying platform handle" handle ifNotNil:[ self primitiveSSLDestroy: handle. handle := nil. ].! ----- Method: SqueakSSL>>encrypt: (in category 'convenience') ----- encrypt: data "Convenience API. Encrypt incoming data and return the result." | buf count | buf := data class new: data size + 100. count := self encrypt: data from: 1 to: data size into: buf. count < 0 ifTrue:[self error: 'Decryption failed, code: ', count]. ^buf copyFrom: 1 to: count! ----- Method: SqueakSSL>>encrypt:from:to:into: (in category 'operations') ----- encrypt: srcBuf from: start to: stop into: dstBuf "Encrypt the input in srcBuf into the provided output buffer. The output buffer must be large enough to include the framing information." ^self primitiveSSL: handle encrypt: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>initialize (in category 'initialize') ----- initialize "Initialize the receiver" handle := self primitiveSSLCreate. ! ----- Method: SqueakSSL>>isConnected (in category 'testing') ----- isConnected "Returns true if the SSL handshake has been completed" ^self sslState = 3! ----- Method: SqueakSSL>>logLevel (in category 'accessing') ----- logLevel "Returns the log level of the ssl instance" ^self primitiveSSL: handle getIntProperty: 1! ----- Method: SqueakSSL>>logLevel: (in category 'accessing') ----- logLevel: aNumber "Sets the log level of the ssl instance" ^self primitiveSSL: handle setIntProperty: 1 toValue: aNumber! ----- Method: SqueakSSL>>on: (in category 'initialize') ----- on: aSocket "Convenience API. Set up SqueakSSL to operate on a standard TCP socket. Generally not very useful for real applications (it lacks error handling etc) but very helpful for debugging and other experiments." self readBlock:[:inbuf| aSocket waitForDataIfClosed:[]. aSocket receiveDataInto: inbuf. ]. self writeBlock:[:outbuf :count| aSocket sendData: (outbuf copyFrom: 1 to: count). ].! ----- Method: SqueakSSL>>peerName (in category 'accessing') ----- peerName "Returns the certificate name of the remote peer. The method only returns a name if the certificate has been verified." ^self primitiveSSL: handle getStringProperty: 0! ----- Method: SqueakSSL>>pluginVersion (in category 'accessing') ----- pluginVersion "Returns the version of the plugin" ^self primitiveSSL: handle getIntProperty: 0! ----- Method: SqueakSSL>>primitiveSSL:accept:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle accept: srcbuf startingAt: start count: length into: dstbuf "Primitive. Starts or continues a server handshake using the provided data. Will eventually produce output to be sent to the server. Returns: > 0 - Number of bytes to be sent to the server 0 - Success. The connection is established. -1 - More input is required. < -1 - Other errors " <primitive: 'primitiveAccept' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:connect:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle connect: srcbuf startingAt: start count: length into: dstbuf "Primitive. Starts or continues a client handshake using the provided data. Will eventually produce output to be sent to the server. Returns: > 0 - Number of bytes to be sent to the server 0 - Success. The connection is established. -1 - More input is required. < -1 - Other errors " <primitive: 'primitiveConnect' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:decrypt:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle decrypt: srcbuf startingAt: start count: length into: dstbuf "Primitive. Takes incoming data for decryption and continues to decrypt data. Returns the number of bytes produced in the output" <primitive: 'primitiveDecrypt' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:encrypt:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle encrypt: srcbuf startingAt: start count: length into: dstbuf "Primitive. Encrypts the incoming buffer into the result buffer. Returns the number of bytes produced as a result." <primitive: 'primitiveEncrypt' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:getIntProperty: (in category 'primitives') ----- primitiveSSL: sslHandle getIntProperty: propID "Primitive. Returns a string property from an SSL session." <primitive: 'primitiveGetIntProperty' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:getStringProperty: (in category 'primitives') ----- primitiveSSL: sslHandle getStringProperty: propID "Primitive. Returns a string property from an SSL session." <primitive: 'primitiveGetStringProperty' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:setIntProperty:toValue: (in category 'primitives') ----- primitiveSSL: sslHandle setIntProperty: propID toValue: anInteger "Primitive. Sets a string property in an SSL session." <primitive: 'primitiveSetIntProperty' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:setStringProperty:toValue: (in category 'primitives') ----- primitiveSSL: sslHandle setStringProperty: propID toValue: aString "Primitive. Sets a string property in an SSL session." <primitive: 'primitiveSetStringProperty' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSLCreate (in category 'primitives') ----- primitiveSSLCreate "Primitive. Creates and returns a new SSL handle" <primitive: 'primitiveCreate' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSLDestroy: (in category 'primitives') ----- primitiveSSLDestroy: sslHandle "Primitive. Destroys the SSL session handle" <primitive: 'primitiveDestroy' module: 'SqueakSSL'> ^self primitiveFailed! ----- Method: SqueakSSL>>readBlock (in category 'accessing') ----- readBlock "The block used to read data where required. The block takes one argument, the buffer to fill with data and is expected to return the number of bytes read." ^readBlock! ----- Method: SqueakSSL>>readBlock: (in category 'accessing') ----- readBlock: aBlock "The block used to read data where required. The block takes one argument, the buffer to fill with data and is expected to return the number of bytes read." readBlock := aBlock! ----- Method: SqueakSSL>>readDataInto: (in category 'private') ----- readDataInto: aBuffer "Private. Read actual data into the given buffer. Return the number of bytes read." ^readBlock value: aBuffer! ----- Method: SqueakSSL>>receiveData (in category 'convenience') ----- receiveData "Convenience API. Receive data and decrypt it." | inbuf outbuf count | inbuf := String new: 4096. outbuf := String new: 4096. ^String streamContents:[:s| "Read the next input bytes" count := self readDataInto: inbuf. "Push the input bytes into the SSL" count := self decrypt: inbuf from: 1 to: count into: outbuf. "And keep draining as long as output is being produced" [count > 0] whileTrue:[ s next: count putAll: outbuf. count := self decrypt: inbuf from: 1 to: 0 into: outbuf. ]. ].! ----- Method: SqueakSSL>>sendData: (in category 'convenience') ----- sendData: inbuf "Convenience API. Encrypt and send data" | outbuf count | outbuf := inbuf class new: inbuf size + 100. count := self encrypt: inbuf from: 1 to: inbuf size into: outbuf. ^self writeData: outbuf count: count.! ----- Method: SqueakSSL>>serverName: (in category 'accessing') ----- serverName: aString "Sets the name to use with the Server Name Indication TLS extension. Which should be a valid FQDN. No WinSSL support yet." ^[ self primitiveSSL: handle setStringProperty: 2 toValue: aString ] on: Error do: [ "nothing" ]! ----- Method: SqueakSSL>>setStringProperty:to: (in category 'private') ----- setStringProperty: index to: aString "Private. Use with caution" ^self primitiveSSL: handle setStringProperty: index toValue: aString! ----- Method: SqueakSSL>>sslState (in category 'accessing') ----- sslState "Returns the current state of the SSL connection: 0 - Unused. 1 - In accept handshake. 2 - In connect handshake. 3 - Connected. " ^self primitiveSSL: handle getIntProperty: 2 ! ----- Method: SqueakSSL>>writeBlock (in category 'accessing') ----- writeBlock "The block used to write data where required. The block takes two arguments, the buffer and the number of bytes to be written from the buffer." ^writeBlock! ----- Method: SqueakSSL>>writeBlock: (in category 'accessing') ----- writeBlock: aBlock "The block used to write data where required. The block takes two arguments, the buffer and the number of bytes to be written from the buffer." writeBlock := aBlock! ----- Method: SqueakSSL>>writeData:count: (in category 'private') ----- writeData: aBuffer count: count "Private. Write actual data from the given buffer." writeBlock value: aBuffer value: count!

1 0

Squeak 4.6: ST80Tools-cmm.8.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of ST80Tools to project Squeak 4.6: http://source.squeak.org/squeak46/ST80Tools-cmm.8.mcz ==================== Summary ==================== Name: ST80Tools-cmm.8 Author: cmm Time: 21 April 2015, 4:49:40.23 pm UUID: 1d69716a-4a2c-44e6-9bae-2613b5590947 Ancestors: ST80Tools-mt.7 Fix underscore assignment. ==================== Snapshot ==================== ----- Method: ParagraphEditor>>browseChangeSetsWithSelector (in category '*ST80Tools') ----- browseChangeSetsWithSelector "Determine which, if any, change sets have at least one change for the selected selector, independent of class" | aSelector | self lineSelectAndEmptyCheck: [^ self]. (aSelector := self selectedSelector) == nil ifTrue: [^ view flash]. self terminateAndInitializeAround: [ChangeSorter browseChangeSetsWithSelector: aSelector]! ----- Method: ParagraphEditor>>browseItHere (in category '*ST80Tools') ----- browseItHere "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw" | aSymbol b | (((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass]) ifFalse: [^ view flash]. model okToChange ifFalse: [^ view flash]. self selectionInterval isEmpty ifTrue: [self selectWord]. (aSymbol := self selectedSymbol) ifNil: [^ view flash]. self terminateAndInitializeAround: [| foundClass | foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]). foundClass ifNil: [^ view flash]. (foundClass isKindOf: Class) ifTrue: [model selectSystemCategory: foundClass category. model classListIndex: (model classList indexOf: foundClass name)]]! ----- Method: ParagraphEditor>>debug:receiver:in: (in category '*ST80Tools') ----- debug: aCompiledMethod receiver: anObject in: evalContext | guineaPig debugger debuggerWindow context | guineaPig := [aCompiledMethod valueWithReceiver: anObject arguments: (evalContext ifNil: [ #() ] ifNotNil: [ { evalContext } ]). guineaPig := nil "spot the return from aCompiledMethod"] newProcess. context := guineaPig suspendedContext. debugger := Debugger new process: guineaPig controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController]) context: context. debuggerWindow := debugger openFullNoSuspendLabel: 'Debug it'. "Now step into the expression. But if it is quick (is implemented as a primtiive, e.g. `0') it will return immediately back to the block that is sent newProcess above. Guard against that with the check for home being thisContext." [debugger interruptedContext method == aCompiledMethod] whileFalse: [(guineaPig isNil and: [debugger interruptedContext home == thisContext]) ifTrue: [debuggerWindow controller closeAndUnschedule. UIManager default inform: 'Nothing to debug; expression is optimized'. ^self]. debugger send]! ----- Method: ParagraphEditor>>debugIt (in category '*ST80Tools') ----- debugIt | method receiver context | (model respondsTo: #doItReceiver) ifTrue: [receiver := model doItReceiver. context := model doItContext] ifFalse: [receiver := context := nil]. self lineSelectAndEmptyCheck: [^self]. method := self compileSelectionFor: receiver in: context. method notNil ifTrue: [self debug: method receiver: receiver in: context].! ----- Method: StringHolderView>>canHaveUnacceptedEdits (in category '*ST80Tools-multi-window support') ----- canHaveUnacceptedEdits "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)" ^true! ----- Method: StringHolderView>>unacceptedEditState (in category '*ST80Tools-multi-window support') ----- unacceptedEditState ^hasUnacceptedEdits ifTrue: [displayContents text]! ----- Method: StringHolderView>>unacceptedEditState: (in category '*ST80Tools-multi-window support') ----- unacceptedEditState: stateOrNil (hasUnacceptedEdits := stateOrNil notNil) ifTrue: [self editString: stateOrNil]! ----- Method: ScreenController>>browseRecentLog (in category '*ST80Tools') ----- browseRecentLog "Open a changelist browser on changes submitted since the last snapshot. 1/17/96 sw" ChangeList browseRecentLog! ----- Method: ScreenController>>chooseDirtyBrowser (in category '*ST80Tools') ----- chooseDirtyBrowser "Put up a list of browsers with unsubmitted edits and activate the one selected by the user, if any." "ScheduledControllers screenController chooseDirtyBrowser" ScheduledControllers findWindowSatisfying: [:c | (c model isKindOf: Browser) and: [c model canDiscardEdits not]]. ! ----- Method: ScreenController>>openChangeManager (in category '*ST80Tools') ----- openChangeManager "Open a dual change sorter. For looking at two change sets at once." DualChangeSorter new open! ----- Method: ScreenController>>openFile (in category '*ST80Tools') ----- openFile FileList openFileDirectly! ----- Method: ScreenController>>openFileList (in category '*ST80Tools') ----- openFileList "Create and schedule a FileList view for specifying files to access." FileList openInMVC! ----- Method: ScreenController>>openPackageBrowser (in category '*ST80Tools') ----- openPackageBrowser "Create and schedule a Browser view for browsing code." PackagePaneBrowser openBrowser! ----- Method: ScreenController>>openSelectorBrowser (in category '*ST80Tools') ----- openSelectorBrowser "Create and schedule a selector fragment window." SelectorBrowser new open! ----- Method: ScreenController>>openSimpleChangeSorter (in category '*ST80Tools') ----- openSimpleChangeSorter ChangeSorter new open! ----- Method: FileList class>>openInMVC (in category '*ST80Tools-instance creation') ----- openInMVC "Open a view of an instance of me on the default directory." | dir aFileList topView volListView templateView fileListView fileContentsView underPane pHeight | dir := FileDirectory default. aFileList := self new directory: dir. topView := StandardSystemView new. topView model: aFileList; label: dir pathName; minimumSize: 200@200. topView borderWidth: 1. volListView := PluggableListView on: aFileList list: #volumeList selected: #volumeListIndex changeSelected: #volumeListIndex: menu: #volumeMenu:. volListView autoDeselect: false. volListView window: (0@0 extent: 80@45). topView addSubView: volListView. templateView := PluggableTextView on: aFileList text: #pattern accept: #pattern:. templateView askBeforeDiscardingEdits: false. templateView window: (0@0 extent: 80@15). topView addSubView: templateView below: volListView. aFileList wantsOptionalButtons ifTrue: [underPane := aFileList optionalButtonViewForMVC. underPane isNil ifTrue: [pHeight := 60] ifFalse: [ topView addSubView: underPane toRightOf: volListView. pHeight := 60 - aFileList optionalButtonHeight]] ifFalse: [underPane := nil. pHeight := 60]. fileListView := PluggableListView on: aFileList list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:. fileListView window: (0@0 extent: 120@pHeight). underPane isNil ifTrue: [topView addSubView: fileListView toRightOf: volListView] ifFalse: [topView addSubView: fileListView below: underPane]. fileListView controller terminateDuringSelect: true. "Pane to left may change under scrollbar" fileContentsView := PluggableTextView on: aFileList text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:. fileContentsView window: (0@0 extent: 200@140). topView addSubView: fileContentsView below: templateView. topView controller open! ----- Method: FileList>>optionalButtonViewForMVC (in category '*ST80Tools-initialization') ----- optionalButtonViewForMVC "Answer a view of optional buttons" | aView bHeight windowWidth offset previousView aButtonView wid services sel allServices | aView := View new model: self. bHeight := self optionalButtonHeight. windowWidth := 120. aView window: (0 @ 0 extent: windowWidth @ bHeight). offset := 0. allServices := self universalButtonServices. services := allServices copyFrom: 1 to: (allServices size min: 5). previousView := nil. services do: [:service | sel := service selector. aButtonView := sel asString numArgs = 0 ifTrue: [PluggableButtonView on: service provider getState: (service extraSelector == #none ifFalse: [service extraSelector]) action: sel] ifFalse: [PluggableButtonView on: service provider getState: (service extraSelector == #none ifFalse: [service extraSelector]) action: sel getArguments: #fullName from: self]. service selector = services last selector ifTrue: [wid := windowWidth - offset] ifFalse: [aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0. wid := windowWidth // services size - 2]. aButtonView label: service buttonLabel asParagraph; window: (offset @ 0 extent: wid @ bHeight). offset := offset + wid. service selector = services first selector ifTrue: [aView addSubView: aButtonView] ifFalse: [aView addSubView: aButtonView toRightOf: previousView]. previousView := aButtonView]. ^ aView!

1 0

Squeak 4.6: PackageInfo-Base-nice.68.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of PackageInfo-Base to project Squeak 4.6: http://source.squeak.org/squeak46/PackageInfo-Base-nice.68.mcz ==================== Summary ==================== Name: PackageInfo-Base-nice.68 Author: nice Time: 17 December 2013, 11:49:21.474 pm UUID: b6669527-9a35-4783-a64f-8f2af97e330b Ancestors: PackageInfo-Base-fbs.67 No need to check if some class selectors are doIt because doIt are no longer installed in method dictionaries. ==================== Snapshot ==================== (PackageInfo named: 'PackageInfo-Base') preamble: '"below, add code to be run before the loading of this package" PackageOrganizer default unregisterPackageNamed: ''PackageInfo''; unregisterPackageNamed: ''ToolBuilder''; unregisterPackageNamed: ''Morphic-TrueType'''! SystemOrganization addCategory: #'PackageInfo-Base'! ----- Method: String>>escapeEntities (in category '*packageinfo-base') ----- escapeEntities ^ self species streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]] ! ----- Method: Character>>escapeEntities (in category '*packageinfo-base') ----- escapeEntities #($< '<' $> '>' $& '&') pairsDo: [:k :v | self = k ifTrue: [^ v]]. ^ String with: self! Object subclass: #PackageInfo instanceVariableNames: 'packageName methodCategoryPrefix preamble postscript preambleOfRemoval postscriptOfRemoval' classVariableNames: '' poolDictionaries: '' category: 'PackageInfo-Base'! PackageInfo class instanceVariableNames: 'default'! !PackageInfo commentStamp: 'bf 7/28/2012 14:11' prior: 0! PackageInfo is used by the system to figure out which classes and methods belong to which package. By default, class categories and method categories are matched against my packageName, but subclasses could override this behavior. For an interesting use of PackageInfo subclasses have a look at OMeta2. It presents the same code base as two different packages, one using decompiled code for bootstrapping, the other using the actual OMeta syntax.! PackageInfo class instanceVariableNames: 'default'! ----- Method: PackageInfo class>>allPackages (in category 'packages access') ----- allPackages ^PackageOrganizer default packages! ----- Method: PackageInfo class>>default (in category 'compatibility') ----- default ^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]! ----- Method: PackageInfo class>>initialize (in category 'class initialization') ----- initialize self allSubclassesDo: [:ea | ea new register]! ----- Method: PackageInfo class>>named: (in category 'packages access') ----- named: aString ^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]! ----- Method: PackageInfo class>>registerPackage: (in category 'registration / unregistration') ----- registerPackage: aString "for compatibility with old fileOuts" ^ Smalltalk at: #FilePackageManager ifPresent: [:p | p registerPackage: aString]! ----- Method: PackageInfo class>>registerPackageName: (in category 'registration / unregistration') ----- registerPackageName: aString ^ PackageOrganizer default registerPackageNamed: aString! ----- Method: PackageInfo>>= (in category 'comparing') ----- = other ^ other species = self species and: [other packageName = self packageName]! ----- Method: PackageInfo>>actualMethodsDo: (in category 'enumerating') ----- actualMethodsDo: aBlock "Evaluate aBlock with the actual method objects in this package." | enum | self extensionMethods do: [:mr| aBlock value: mr compiledMethod]. enum := [:behavior| behavior organization categories do: [:cat| (self isForeignClassExtension: cat) ifFalse: [(behavior organization listAtCategoryNamed: cat) do: [:s| aBlock value: (behavior compiledMethodAt: s)]]]]. self classes do: [:c| enum value: c; value: c classSide] ! ----- Method: PackageInfo>>addCoreMethod: (in category 'modifying') ----- addCoreMethod: aMethodReference | category | category := self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference methodSymbol under: category suppressIfDefault: false! ----- Method: PackageInfo>>addExtensionMethod: (in category 'modifying') ----- addExtensionMethod: aMethodReference | category | category := self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference methodSymbol under: self methodCategoryPrefix, '-', category! ----- Method: PackageInfo>>addMethod: (in category 'modifying') ----- addMethod: aMethodReference (self includesClass: aMethodReference class) ifTrue: [self addCoreMethod: aMethodReference] ifFalse: [self addExtensionMethod: aMethodReference]! ----- Method: PackageInfo>>allOverriddenMethods (in category 'listing') ----- allOverriddenMethods "search classes and meta classes" ^ Array streamContents: [:stream | self allOverriddenMethodsDo: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>allOverriddenMethodsDo: (in category 'enumerating') ----- allOverriddenMethodsDo: aBlock "Evaluates aBlock with all the overridden methods in the system" ^ ProtoObject withAllSubclassesDo: [:class | self overriddenMethodsInClass: class do: aBlock] ! ----- Method: PackageInfo>>baseCategoryOfMethod: (in category '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: $- ]]! ----- Method: PackageInfo>>category:matches: (in category 'testing') ----- category: categoryName matches: prefix | prefixSize catSize | categoryName ifNil: [ ^false ]. catSize := categoryName size. prefixSize := prefix size. catSize < prefixSize ifTrue: [ ^false ]. (categoryName findString: prefix startingAt: 1 caseSensitive: false) = 1 ifFalse: [ ^false ]. ^(categoryName at: prefix size + 1 ifAbsent: [ ^true ]) = $-! ----- Method: PackageInfo>>categoryName (in category 'naming') ----- categoryName |category| category := self class category. ^ (category endsWith: '-Info') ifTrue: [category copyUpToLast: $-] ifFalse: [category]! ----- Method: PackageInfo>>changeRecordForOverriddenMethod: (in category 'testing') ----- changeRecordForOverriddenMethod: aMethodReference self changeRecordsForMethod: aMethodReference do: [:record | (self includesMethodCategory: record category ofClass: aMethodReference actualClass) ifTrue: [^record]]. ^nil! ----- Method: PackageInfo>>changeRecordsForMethod:do: (in category 'enumerating') ----- changeRecordsForMethod: aMethodReference do: aBlock "Evaluate aBlock with one ChangeRecord per overriding package, followed by the latest non-override" | overridingPackages method position sourceFilesCopy | overridingPackages := Set new. method := aMethodReference compiledMethod. position := method filePosition. sourceFilesCopy := SourceFiles collect: [:x | x ifNotNil: [x readOnlyCopy]]. [ | file prevPos prevFileIndex chunk stamp methodCategory methodPackage tokens | method fileIndex = 0 ifTrue: [^ nil]. file := sourceFilesCopy at: method fileIndex. [position notNil & file notNil] whileTrue: [file position: (0 max: position-150). "Skip back to before the preamble" [file position < (position-1)] "then pick it up from the front" whileTrue: [chunk := file nextChunk]. "Preamble is likely a linked method preamble, if we're in a changes file (not the sources file). Try to parse it for prior source position and file index" prevPos := nil. stamp := ''. (chunk findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [tokens := Scanner new scanTokens: chunk] ifFalse: [tokens := Array new "ie cant be back ref"]. ((tokens size between: 7 and: 8) and: [(tokens at: tokens size-5) = #methodsFor:]) ifTrue: [(tokens at: tokens size-3) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size-2. prevPos := tokens last. prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos] ifFalse: ["Old format gives no stamp; prior pointer in two parts" prevPos := tokens at: tokens size-2. prevFileIndex := tokens last]. (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]]. ((tokens size between: 5 and: 6) and: [(tokens at: tokens size-3) = #methodsFor:]) ifTrue: [(tokens at: tokens size-1) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size]]. methodCategory := tokens after: #methodsFor: ifAbsent: [ClassOrganizer default]. methodPackage := PackageOrganizer default packageOfMethodCategory: methodCategory ofClass: aMethodReference actualClass ifNone: [#unknown]. (overridingPackages includes: methodPackage) ifFalse: [aBlock value: (ChangeRecord new file: file position: position type: #method class: aMethodReference classSymbol category: methodCategory meta: aMethodReference classIsMeta stamp: stamp)]. (self isOverrideCategory: methodCategory) ifTrue: [overridingPackages add: methodPackage] ifFalse: [(overridingPackages includes: methodPackage) ifFalse: [^nil]]. position := prevPos. prevPos notNil ifTrue: [file := sourceFilesCopy at: prevFileIndex]]. ^nil] ensure: [sourceFilesCopy do: [:x | x ifNotNil: [x close]]] ! ----- Method: PackageInfo>>classes (in category 'listing') ----- classes ^(self systemCategories gather: [:cat | (SystemOrganization listAtCategoryNamed: cat) collect: [:className | Smalltalk at: className]]) sortBy: [:a :b | a className <= b className]! ----- Method: PackageInfo>>classesAndMetaClasses (in category 'listing') ----- classesAndMetaClasses "Return a Set with all classes and metaclasses belonging to this package" | baseClasses result | baseClasses := self classes. result := (Set new: baseClasses size * 2) addAll: baseClasses; yourself. baseClasses do: [ :c | result add: c classSide]. ^result ! ----- Method: PackageInfo>>coreCategoriesForClass: (in category 'testing') ----- coreCategoriesForClass: aClass ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]! ----- Method: PackageInfo>>coreMethods (in category 'listing') ----- coreMethods ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! ----- Method: PackageInfo>>coreMethodsForClass: (in category 'testing') ----- coreMethodsForClass: aClass ^ (aClass selectors difference: ((self foreignExtensionMethodsForClass: aClass) collect: [:r | r methodSymbol])) asArray collect: [:sel | self referenceForMethod: sel ofClass: aClass]! ----- Method: PackageInfo>>extensionCategoriesForClass: (in category 'testing') ----- extensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! ----- Method: PackageInfo>>extensionClasses (in category 'listing') ----- extensionClasses ^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]! ----- Method: PackageInfo>>extensionMethods (in category 'listing') ----- extensionMethods ^ self externalBehaviors gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]! ----- Method: PackageInfo>>extensionMethodsForClass: (in category 'testing') ----- extensionMethodsForClass: aClass ^ (self extensionCategoriesForClass: aClass) gather: [:cat | self methodsInCategory: cat ofClass: aClass ]! ----- Method: PackageInfo>>extensionMethodsFromClasses: (in category 'testing') ----- extensionMethodsFromClasses: classes ^classes gather: [:class | self extensionMethodsForClass: class]! ----- Method: PackageInfo>>externalBehaviors (in category 'modifying') ----- externalBehaviors ^self externalClasses , self externalTraits! ----- Method: PackageInfo>>externalCallers (in category 'dependencies') ----- externalCallers ^ self externalRefsSelect: [:literal | literal isKindOf: Symbol] thenCollect: [:l | l].! ----- Method: PackageInfo>>externalClasses (in category 'dependencies') ----- externalClasses | myClasses | myClasses := self classesAndMetaClasses. ^ Array streamContents: [:s | ProtoObject withAllSubclassesDo: [:class | (myClasses includes: class) ifFalse: [s nextPut: class]]]! ----- Method: PackageInfo>>externalName (in category 'naming') ----- externalName ^ self packageName! ----- Method: PackageInfo>>externalRefsSelect:thenCollect: (in category 'dependencies') ----- externalRefsSelect: selBlock thenCollect: colBlock | pkgMethods dependents 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 | | refs | (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! ----- Method: PackageInfo>>externalSubclasses (in category 'dependencies') ----- externalSubclasses | pkgClasses subClasses | pkgClasses := self classes. subClasses := Set new. pkgClasses do: [:c | subClasses addAll: (c allSubclasses)]. ^ subClasses difference: pkgClasses ! ----- Method: PackageInfo>>externalTraits (in category 'modifying') ----- externalTraits ^ Array streamContents: [:s | | behaviors | behaviors := self classesAndMetaClasses. Smalltalk allTraits do: [:trait | (behaviors includes: trait) ifFalse: [s nextPut: trait]. (behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]]. ! ----- Method: PackageInfo>>externalUsers (in category 'dependencies') ----- externalUsers ^ self externalRefsSelect: [:literal | literal isVariableBinding] thenCollect: [:l | l key]! ----- Method: PackageInfo>>foreignClasses (in category '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! ----- Method: PackageInfo>>foreignExtensionCategoriesForClass: (in category 'testing') ----- foreignExtensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]! ----- Method: PackageInfo>>foreignExtensionMethodsForClass: (in category 'testing') ----- foreignExtensionMethodsForClass: aClass ^ (self foreignExtensionCategoriesForClass: aClass) gather: [:cat | (aClass organization listAtCategoryNamed: cat) collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ----- Method: PackageInfo>>foreignSystemCategories (in category 'listing') ----- foreignSystemCategories ^ SystemOrganization categories reject: [:cat | self includesSystemCategory: cat] ! ----- Method: PackageInfo>>hasPostscript (in category 'preamble/postscript') ----- hasPostscript ^ self isScript: postscript not: self postscriptDefault! ----- Method: PackageInfo>>hasPostscriptOfRemoval (in category 'preamble/postscript') ----- hasPostscriptOfRemoval ^ self isScript: postscriptOfRemoval not: self postscriptOfRemovalDefault! ----- Method: PackageInfo>>hasPreamble (in category 'preamble/postscript') ----- hasPreamble ^ self isScript: preamble not: self preambleDefault! ----- Method: PackageInfo>>hasPreambleOfRemoval (in category 'preamble/postscript') ----- hasPreambleOfRemoval ^ self isScript: preambleOfRemoval not: self preambleOfRemovalDefault! ----- Method: PackageInfo>>hash (in category 'comparing') ----- hash ^ packageName hash! ----- Method: PackageInfo>>includesChangeRecord: (in category 'testing') ----- includesChangeRecord: aChangeRecord ^ aChangeRecord methodClass notNil and: [self includesMethodCategory: aChangeRecord category ofClass: aChangeRecord methodClass]! ----- Method: PackageInfo>>includesClass: (in category 'testing') ----- includesClass: aClass ^ self includesSystemCategory: aClass category! ----- Method: PackageInfo>>includesClassNamed: (in category 'testing') ----- includesClassNamed: aClassName ^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])! ----- Method: PackageInfo>>includesMethod:ofClass: (in category 'testing') ----- includesMethod: aSymbol ofClass: aClass aClass ifNil: [^ false]. ^ self includesMethodCategory: ((aClass organization categoryOfElement: aSymbol) ifNil: [' ']) ofClass: aClass! ----- Method: PackageInfo>>includesMethodCategory:ofClass: (in category 'testing') ----- includesMethodCategory: categoryName ofClass: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClass: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ----- Method: PackageInfo>>includesMethodCategory:ofClassNamed: (in category 'testing') ----- includesMethodCategory: categoryName ofClassNamed: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClassNamed: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ----- Method: PackageInfo>>includesMethodReference: (in category 'testing') ----- includesMethodReference: aMethodRef ^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass! ----- Method: PackageInfo>>includesSystemCategory: (in category 'testing') ----- includesSystemCategory: categoryName ^ self category: categoryName matches: self systemCategoryPrefix! ----- Method: PackageInfo>>isForeignClassExtension: (in category 'testing') ----- isForeignClassExtension: categoryName ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! ----- Method: PackageInfo>>isOverrideCategory: (in category 'testing') ----- isOverrideCategory: aString ^ aString first = $* and: [aString endsWith: '-override']! ----- Method: PackageInfo>>isOverrideMethod: (in category 'testing') ----- isOverrideMethod: aMethodReference ^ self isOverrideCategory: aMethodReference category! ----- Method: PackageInfo>>isOverrideOfYourMethod: (in category 'testing') ----- isOverrideOfYourMethod: aMethodReference "Answers true if the argument overrides a method in this package" ^ (self isYourClassExtension: aMethodReference category) not and: [(self changeRecordForOverriddenMethod: aMethodReference) notNil]! ----- Method: PackageInfo>>isScript:not: (in category 'preamble/postscript') ----- isScript: script not: default ^ script notNil and: [ | contents | contents := script contents asString withBlanksTrimmed. contents notEmpty and: [contents ~= default and: [contents ~= 'nil']]]! ----- Method: PackageInfo>>isYourClassExtension: (in category 'testing') ----- isYourClassExtension: categoryName ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! ----- Method: PackageInfo>>linesOfCode (in category 'source code management') ----- linesOfCode "An approximate measure of lines of code. Includes comments, but excludes blank lines." ^self methods inject: 0 into: [:sum :each | sum + each compiledMethod linesOfCode]! ----- Method: PackageInfo>>methodCategoryPrefix (in category 'naming') ----- methodCategoryPrefix ^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]! ----- Method: PackageInfo>>methods (in category 'listing') ----- methods ^ (self extensionMethods, self coreMethods) select: [:method | method isValid and: [method isLocalSelector]]! ----- Method: PackageInfo>>methodsInCategory:ofClass: (in category 'testing') ----- methodsInCategory: aString ofClass: aClass ^Array streamContents: [:stream | self methodsInCategory: aString ofClass: aClass do: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>methodsInCategory:ofClass:do: (in category 'enumerating') ----- methodsInCategory: aString ofClass: aClass do: aBlock ((aClass organization listAtCategoryNamed: aString) ifNil: [^self]) do: [:sel | aBlock value: (self referenceForMethod: sel ofClass: aClass)]! ----- Method: PackageInfo>>name (in category 'naming') ----- name ^ self packageName! ----- Method: PackageInfo>>outsideClasses (in category 'testing') ----- outsideClasses ^ProtoObject withAllSubclasses asSet difference: self classesAndMetaClasses! ----- Method: PackageInfo>>overriddenMethods (in category 'listing') ----- overriddenMethods ^ Array streamContents: [:stream | self overriddenMethodsDo: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>overriddenMethodsDo: (in category 'enumerating') ----- overriddenMethodsDo: aBlock "Enumerates the methods the receiver contains which have been overridden by other packages" ^ self allOverriddenMethodsDo: [:ea | (self isOverrideOfYourMethod: ea) ifTrue: [aBlock value: ea]]! ----- Method: PackageInfo>>overriddenMethodsInClass: (in category 'listing') ----- overriddenMethodsInClass: aClass ^Array streamContents: [:stream | self overriddenMethodsInClass: aClass do: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>overriddenMethodsInClass:do: (in category 'enumerating') ----- overriddenMethodsInClass: aClass do: aBlock "Evaluates aBlock with the overridden methods in aClass" ^ self overrideCategoriesForClass: aClass do: [:cat | self methodsInCategory: cat ofClass: aClass do: aBlock]! ----- Method: PackageInfo>>overrideCategoriesForClass: (in category 'testing') ----- overrideCategoriesForClass: aClass ^Array streamContents: [:stream | self overrideCategoriesForClass: aClass do: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>overrideCategoriesForClass:do: (in category 'enumerating') ----- overrideCategoriesForClass: aClass do: aBlock "Evaluates aBlock with all the *foo-override categories in aClass" ^ aClass organization categories do: [:cat | (self isOverrideCategory: cat) ifTrue: [aBlock value: cat]]! ----- Method: PackageInfo>>overrideMethods (in category 'listing') ----- overrideMethods ^ self extensionMethods select: [:ea | self isOverrideMethod: ea]! ----- Method: PackageInfo>>packageName (in category 'naming') ----- packageName ^ packageName ifNil: [packageName := self categoryName]! ----- Method: PackageInfo>>packageName: (in category 'naming') ----- packageName: aString packageName := aString! ----- Method: PackageInfo>>postscript (in category 'preamble/postscript') ----- postscript ^ postscript ifNil: [ postscript := StringHolder new contents: self postscriptDefault]! ----- Method: PackageInfo>>postscript: (in category 'preamble/postscript') ----- postscript: aString postscript := StringHolder new contents: aString! ----- Method: PackageInfo>>postscriptDefault (in category 'preamble/postscript') ----- postscriptDefault ^ '"below, add code to be run after the loading of this package"'! ----- Method: PackageInfo>>postscriptOfRemoval (in category 'preamble/postscript') ----- postscriptOfRemoval ^ postscriptOfRemoval ifNil: [ postscriptOfRemoval := StringHolder new contents: self postscriptOfRemovalDefault]! ----- Method: PackageInfo>>postscriptOfRemoval: (in category 'preamble/postscript') ----- postscriptOfRemoval: aString postscriptOfRemoval := StringHolder new contents: aString ! ----- Method: PackageInfo>>postscriptOfRemovalDefault (in category 'preamble/postscript') ----- postscriptOfRemovalDefault ^ '"below, add code to clean up after the unloading of this package"'! ----- Method: PackageInfo>>preamble (in category 'preamble/postscript') ----- preamble ^ preamble ifNil: [ preamble := StringHolder new contents: self preambleDefault]! ----- Method: PackageInfo>>preamble: (in category 'preamble/postscript') ----- preamble: aString preamble := StringHolder new contents: aString! ----- Method: PackageInfo>>preambleDefault (in category 'preamble/postscript') ----- preambleDefault ^ '"below, add code to be run before the loading of this package"' ! ----- Method: PackageInfo>>preambleOfRemoval (in category 'preamble/postscript') ----- preambleOfRemoval ^ preambleOfRemoval ifNil: [ preambleOfRemoval := StringHolder new contents: self preambleOfRemovalDefault]! ----- Method: PackageInfo>>preambleOfRemoval: (in category 'preamble/postscript') ----- preambleOfRemoval: aString preambleOfRemoval := StringHolder new contents: aString ! ----- Method: PackageInfo>>preambleOfRemovalDefault (in category 'preamble/postscript') ----- preambleOfRemovalDefault ^'"below, add code to prepare for the unloading of this package"'! ----- Method: PackageInfo>>printOn: (in category 'printing') ----- printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self packageName; nextPut: $)! ----- Method: PackageInfo>>referenceForMethod:ofClass: (in category 'testing') ----- referenceForMethod: aSymbol ofClass: aClass ^ MethodReference class: aClass selector: aSymbol! ----- Method: PackageInfo>>register (in category 'registering') ----- register PackageOrganizer default registerPackage: self! ----- Method: PackageInfo>>removeMethod: (in category 'modifying') ----- removeMethod: aMethodReference! ----- Method: PackageInfo>>selectors (in category 'listing') ----- selectors ^ self methods collect: [:ea | ea methodSymbol]! ----- Method: PackageInfo>>systemCategories (in category 'listing') ----- systemCategories ^ SystemOrganization categories select: [:cat | self includesSystemCategory: cat]! ----- Method: PackageInfo>>systemCategoryPrefix (in category 'naming') ----- systemCategoryPrefix ^ self packageName! Object subclass: #PackageOrganizer instanceVariableNames: 'packages' classVariableNames: '' poolDictionaries: '' category: 'PackageInfo-Base'! PackageOrganizer class instanceVariableNames: 'default'! PackageOrganizer class instanceVariableNames: 'default'! ----- Method: PackageOrganizer class>>default (in category 'as yet unclassified') ----- default ^ default ifNil: [default := self new]! ----- Method: PackageOrganizer class>>new (in category 'as yet unclassified') ----- new ^ self basicNew initialize! ----- Method: PackageOrganizer>>flushObsoletePackages: (in category 'registering') ----- flushObsoletePackages: aBlock "Flush all packages considered obsolete by evaluating the argument block." packages keys do:[:key| (aBlock value: (packages at: key)) ifTrue:[packages removeKey: key]. ]. self changed: #packages; changed: #packageNames.! ----- Method: PackageOrganizer>>initialize (in category 'initializing') ----- initialize packages := Dictionary new! ----- Method: PackageOrganizer>>noPackageFound (in category 'searching') ----- noPackageFound self error: 'No package found'! ----- Method: PackageOrganizer>>packageNamed:ifAbsent: (in category 'searching') ----- packageNamed: aString ifAbsent: errorBlock ^ packages at: aString ifAbsent: errorBlock! ----- Method: PackageOrganizer>>packageNames (in category 'accessing') ----- packageNames ^ packages keys! ----- Method: PackageOrganizer>>packageOfClass: (in category 'searching') ----- packageOfClass: aClass ^ self packageOfClass: aClass ifNone: [self noPackageFound]! ----- Method: PackageOrganizer>>packageOfClass:ifNone: (in category 'searching') ----- packageOfClass: aClass ifNone: errorBlock ^ self packages detect: [:ea | ea includesClass: aClass] ifNone: errorBlock! ----- Method: PackageOrganizer>>packageOfMethod: (in category 'searching') ----- packageOfMethod: aMethodReference ^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]! ----- Method: PackageOrganizer>>packageOfMethod:ifNone: (in category 'searching') ----- packageOfMethod: aMethodReference ifNone: errorBlock ^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock! ----- Method: PackageOrganizer>>packageOfMethodCategory:ofClass: (in category 'searching') ----- packageOfMethodCategory: categoryName ofClass: aClass ^self packageOfMethodCategory: categoryName ofClass: aClass ifNone: [ self noPackageFound ] ! ----- Method: PackageOrganizer>>packageOfMethodCategory:ofClass:ifNone: (in category 'searching') ----- packageOfMethodCategory: categoryName ofClass: aClass ifNone: errorBlock ^ self packages detect: [:ea | ea includesMethodCategory: categoryName ofClassNamed: aClass name] ifNone: errorBlock ! ----- Method: PackageOrganizer>>packageOfSystemCategory: (in category 'searching') ----- packageOfSystemCategory: aSystemCategory ^ self packageOfSystemCategory: aSystemCategory ifNone: [ self noPackageFound ] ! ----- Method: PackageOrganizer>>packageOfSystemCategory:ifNone: (in category 'searching') ----- packageOfSystemCategory: aSystemCategory ifNone: errorBlock ^ self packages detect: [:ea | ea includesSystemCategory: aSystemCategory] ifNone: errorBlock ! ----- Method: PackageOrganizer>>packages (in category 'accessing') ----- packages ^ packages values! ----- Method: PackageOrganizer>>registerPackage: (in category 'registering') ----- registerPackage: aPackageInfo packages at: aPackageInfo packageName put: aPackageInfo. self changed: #packages; changed: #packageNames. ! ----- Method: PackageOrganizer>>registerPackageNamed: (in category 'registering') ----- registerPackageNamed: aString ^ self registerPackage: (PackageInfo named: aString)! ----- Method: PackageOrganizer>>unregisterPackage: (in category 'registering') ----- unregisterPackage: aPackageInfo packages removeKey: aPackageInfo packageName ifAbsent: []. self changed: #packages; changed: #packageNames. ! ----- Method: PackageOrganizer>>unregisterPackageNamed: (in category 'registering') ----- unregisterPackageNamed: aString self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])! Object subclass: #PackageServices instanceVariableNames: '' classVariableNames: 'ServiceClasses' poolDictionaries: '' category: 'PackageInfo-Base'! ----- Method: PackageServices class>>allServices (in category 'as yet unclassified') ----- allServices ^ ServiceClasses gather: [:ea | ea services]! ----- Method: PackageServices class>>initialize (in category 'as yet unclassified') ----- initialize ServiceClasses := Set new! ----- Method: PackageServices class>>register: (in category 'as yet unclassified') ----- register: aClass ServiceClasses add: aClass! ----- Method: PackageServices class>>unregister: (in category 'as yet unclassified') ----- unregister: aClass ServiceClasses remove: aClass! ----- Method: PositionableStream>>untilEnd:displayingProgress: (in category '*packageinfo-base') ----- untilEnd: aBlock displayingProgress: aString aString displayProgressFrom: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. aBlock value]].!

1 0

Squeak 4.6: SUnitTools-mt.3.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SUnitTools to project Squeak 4.6: http://source.squeak.org/squeak46/SUnitTools-mt.3.mcz ==================== Summary ==================== Name: SUnitTools-mt.3 Author: mt Time: 19 April 2015, 7:21:55.82 am UUID: c2d3c452-b6ad-3b4a-ab7e-4b5f750648c0 Ancestors: SUnitTools-topa.2 Moved test for being a test-class to SUnit. ==================== Snapshot ==================== ----- Method: StringHolder>>hasClassWithTestsSelected (in category '*SUnitTools-testing') ----- hasClassWithTestsSelected ^ self selectedClass ifNil: [false] ifNotNil: [:cls | cls isTestClass and: [cls isAbstract not]]! ----- Method: Browser>>hasSystemCategoryWithTestsSelected (in category '*SUnitTools-system category functions') ----- hasSystemCategoryWithTestsSelected (systemOrganizer listAtCategoryNamed: (self selectedSystemCategory ifNil: [^ false])) detect: [:name | self class environment at: name ifPresent: [:cls | cls isTestClass and: [cls isAbstract not]] ifAbsent: [false]] ifNone: [^ false]. ^ true ! ----- Method: Browser>>testRunTests (in category '*SUnitTools-class list functions') ----- testRunTests self testRunSuite: self selectedClass suite. self changed: #classList. self changed: #messageList.! ----- Method: Browser>>testRunTestsCategory (in category '*SUnitTools-system category functions') ----- testRunTestsCategory | suite | suite :=TestSuite new. ((systemOrganizer listAtCategoryNamed: self selectedSystemCategory) collect: [:each | self class environment at: each]) select: [:each | each isTestClass and: [each isAbstract not]] thenDo: [:each | each addToSuiteFromSelectors: suite]. self testRunSuite: suite. self changed: #classList. self changed: #messageList.! ----- Method: Browser>>testsClassListMenu: (in category '*SUnitTools-menus') ----- testsClassListMenu: aMenu <classListMenu> self hasClassWithTestsSelected ifFalse: [^ aMenu]. ^ aMenu addList: #( - ('run all tests' testRunTests)); yourself! ----- Method: Browser>>testsSystemCategoryMenu: (in category '*SUnitTools-menus') ----- testsSystemCategoryMenu: aMenu <systemCategoryMenu> self hasSystemCategoryWithTestsSelected ifFalse: [^ aMenu]. ^ aMenu addList: #( - ('run all tests' testRunTestsCategory)); yourself! ----- Method: CodeHolder>>testBinarySelectorNames (in category '*SUnitTools-running') ----- testBinarySelectorNames ^ IdentityDictionary newFromPairs: #( #& 'conjunction' #| 'disjunction' #==> 'implication' #* 'multiply' #+ 'add' #- 'subtract' #/ 'divide' #// 'remainder' #\\ 'modulo' #<< 'shiftLeft' #>> 'shiftRight' #= 'equality' #== 'identity' #~= 'difference' #~~ 'mismatch' #< 'lessThan' #<= 'lessOrEqualThan' #> 'greaterThan' #>= 'greaterOrEqualThan' #<=> 'spaceshipOperator' #@ 'at' #, 'concatenation' #-> 'association' #=> 'binding' ) ! ----- Method: CodeHolder>>testBrowseClassNamed:possibleMessageNamed: (in category '*SUnitTools-running') ----- testBrowseClassNamed: aClassName possibleMessageNamed: aMessageName | cls selector | (self class environment hasClassNamed: aClassName) ifFalse: ["no dice" ^ self]. cls := self class environment classNamed: aClassName. (aMessageName notNil and: [cls includesLocalSelector: (selector := aMessageName asSymbol)]) ifTrue: [ToolSet browse: cls selector: selector] ifFalse: [ToolSet browseClass: cls].! ----- Method: CodeHolder>>testDebugTest (in category '*SUnitTools-message list functions') ----- testDebugTest | case selector cls | cls := self selectedClass ifNil: [^ self]. selector := self selectedMessageName ifNil: [^ self]. case := cls selector: selector. case debugAsFailure.! ----- Method: CodeHolder>>testFindTest (in category '*SUnitTools-running') ----- testFindTest | cls destClassName destMessage | cls := self selectedClass ifNil: [^ self]. cls isTestClass ifTrue: [" already there " ^ self]. destClassName := cls name asString, 'Test'. destMessage := self selectedMessageName ifNotNil: [:name | self testSelectorFrom: name]. self testBrowseClassNamed: destClassName possibleMessageNamed: destMessage ! ----- Method: CodeHolder>>testFindTested (in category '*SUnitTools-running') ----- testFindTested | cls destClassName destMessage | cls := self selectedClass ifNil: [^ self]. cls isTestClass ifFalse: [" already there " ^ self]. destClassName := (cls name asString endsWith: 'Test') ifTrue: [cls name asString allButLast: 4] ifFalse: [^ self]. destMessage := self selectedMessageName ifNotNil: [:selector | | messageName | messageName := selector asString. (messageName beginsWith: 'test') "operate on test methods only" ifTrue: [ (self class environment classNamed: destClassName) ifNotNil: [:destClass | destClass selectors detect: [:destSelector | (self testSelectorFrom: destSelector) = messageName] ifNone: [nil]]] ifFalse: [nil]]. self testBrowseClassNamed: destClassName possibleMessageNamed: destMessage ! ----- Method: CodeHolder>>testRunSuite: (in category '*SUnitTools-running') ----- testRunSuite: suite | result | result := suite run. (result respondsTo: #dispatchResultsIntoHistory) ifTrue: [result dispatchResultsIntoHistory]. result hasPassed ifTrue: [^ self]. (result defects size = 1 ifTrue: [result defects anyOne] ifFalse: [UIManager default chooseFrom: (result defects collect: [:each | each class name , '>>' , each selector printString]) values: result defects title: ('{1} passes, {2} failures, {3} errors\\Debug a failure or error?' format: { result runCount . result failureCount . result errorCount}) withCRs] ) ifNotNil: [:defect | defect debug]. ! ----- Method: CodeHolder>>testRunTest (in category '*SUnitTools-message list functions') ----- testRunTest | suite | suite := self selectedClass selector: self selectedMessageName. self testRunSuite: suite. self changed: #messageList.! ----- Method: CodeHolder>>testSelectorFrom: (in category '*SUnitTools-running') ----- testSelectorFrom: aSelector | name | name := aSelector isBinary ifTrue: [self testBinarySelectorNames at: aSelector ifAbsent: [^ nil]] ifFalse: [aSelector asString]. ^ String streamContents: [:stream | stream nextPutAll: 'test'. (name findTokens: $:) do: [:each | stream nextPutAll: (each capitalized select: [:char | char isAlphaNumeric])]]! ----- Method: CodeHolder>>testsMessageListMenu: (in category '*SUnitTools-menus') ----- testsMessageListMenu: aMenu <messageListMenu> (self selectedClass isTestClass and: [self selectedClass isAbstract not and: [self selectedClass allTestSelectors includes: self selectedMessageName]]) ifFalse: [^ aMenu]. ^ aMenu addList: #( - ('run test' testRunTest) ('debug test' testDebugTest)); yourself! ----- Method: CodeHolder>>testsTestFindingMenu: (in category '*SUnitTools-menus') ----- testsTestFindingMenu: aMenu <classListMenu> <messageListMenu> ^ self hasClassWithTestsSelected ifTrue: [aMenu add: 'find tested item' action: #testFindTested; yourself] ifFalse: [aMenu add: 'find test case' action: #testFindTest; yourself] ! ----- Method: TestCase class>>toolIcon (in category '*SUnitTools-icons') ----- toolIcon | classHistory | self isAbstract ifTrue: [^ super toolIcon]. classHistory := TestResult historyFor: self. (classHistory at: #errors) ifNotEmpty: [^ #testRed]. (classHistory at: #failures) ifNotEmpty: [^ #testOrange]. (classHistory at: #passed) ifNotEmpty: [ ^ #testGreen]. ^ #testGray! ----- Method: TestCase class>>toolIconSelector: (in category '*SUnitTools-icons') ----- toolIconSelector: aSelector (self isMeta or: [self isAbstract or: [ (self allTestSelectors includes: aSelector) not]]) ifTrue: [^ super toolIconSelector: aSelector]. (self methodRaisedError: aSelector) ifTrue: [^ #testRed]. (self methodFailed: aSelector) ifTrue: [^ #testOrange]. (self methodPassed: aSelector) ifTrue: [^ #testGreen]. ^ #testGray! ----- Method: ToolIcons class>>testGray (in category '*SUnitTools-icons') ----- testGray ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294177779 4291217094 4288585374 4288453788 4290953922 4294111986 0 0 0 0 0 0 4291217094 4291151301 4292796126 4292532954 4290690750 4290624957 0 0 0 0 0 0 4288585374 4292730333 4290953922 4290427578 4291414473 4287466893 0 0 0 0 0 0 4288387995 4292203989 4290493371 4290164406 4291019715 4287072135 0 0 0 0 0 0 4290822336 4290624957 4291414473 4291019715 4290230199 4289835441 0 0 0 0 0 0 4294111986 4290493371 4287269514 4286940549 4289769648 4293848814 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ----- Method: ToolIcons class>>testGreen (in category '*SUnitTools-icons') ----- testGreen ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4293720299 4288666780 4284466010 4284465241 4288599706 4293654250 0 0 0 0 0 0 4288666780 4288403095 4290962113 4290502586 4288007314 4288401048 0 0 0 0 0 0 4284465754 4290830784 4288008853 4287220872 4288992418 4283999824 0 0 0 0 0 0 4284398936 4290108596 4287351946 4286958211 4288532634 4283800910 0 0 0 0 0 0 4288533401 4288007057 4288926881 4288401561 4287677068 4288133778 0 0 0 0 0 0 4293653994 4288400279 4283867471 4283734348 4288067729 4293521384 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ----- Method: ToolIcons class>>testOrange (in category '*SUnitTools-icons') ----- testOrange ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294964456 4294953101 4294943038 4294942778 4294951813 4294963941 0 0 0 0 0 0 4294953101 4294952588 4294959549 4294958774 4294951038 4294688127 0 0 0 0 0 0 4294943293 4294959548 4294953862 4294951029 4294954132 4293888298 0 0 0 0 0 0 4294941751 4294957228 4294951287 4294949998 4294952328 4293165354 0 0 0 0 0 0 4294951298 4294950267 4294954131 4294952583 4294948207 4293110399 0 0 0 0 0 0 4294898405 4294424959 4293559850 4292902442 4292979327 4294438117 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ----- Method: ToolIcons class>>testRed (in category '*SUnitTools-icons') ----- testRed ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294960869 4294935167 4294716714 4294389034 4294344831 4294764005 0 0 0 0 0 0 4294935167 4294803840 4294687929 4294620593 4293950845 4293623680 0 0 0 0 0 0 4294585642 4294687928 4294477438 4294276206 4294284433 4292028973 0 0 0 0 0 0 4294061098 4294487209 4294276976 4294208615 4294150278 4291242543 0 0 0 0 0 0 4294082687 4293819516 4294284176 4294150277 4293163129 4291854213 0 0 0 0 0 0 4294698469 4293296000 4291635758 4290914863 4291657605 4294174183 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0!

1 0

Squeak 4.6: HelpSystem-Core-mt.78.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of HelpSystem-Core to project Squeak 4.6: http://source.squeak.org/squeak46/HelpSystem-Core-mt.78.mcz ==================== Summary ==================== Name: HelpSystem-Core-mt.78 Author: mt Time: 14 May 2015, 6:45:57.427 pm UUID: d3d02275-f61e-8f4f-91e0-5dcf9b37c8d5 Ancestors: HelpSystem-Core-kfr.77 Class-based help topics are editable again. Help browser updates correctly after edits. ==================== Snapshot ==================== SystemOrganization addCategory: #'HelpSystem-Core-Builders'! SystemOrganization addCategory: #'HelpSystem-Core-Help'! SystemOrganization addCategory: #'HelpSystem-Core-Model'! SystemOrganization addCategory: #'HelpSystem-Core-UI'! SystemOrganization addCategory: #'HelpSystem-Core-Utilities'! (PackageInfo named: 'HelpSystem-Core') postscript: '"below, add code to be run after the loading of this package" TheWorldMainDockingBar updateInstances'! Model subclass: #AbstractHelpTopic instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !AbstractHelpTopic commentStamp: 'mt 3/24/2015 16:26' prior: 0! A HelpTopic provides content information that can be used as a help to the user. It can be labeled with a title and marked with an (optional) icon. Help topics form a hierarchy since any topic is able to have zero or more subtopics. ! ----- Method: AbstractHelpTopic>><= (in category 'comparing') ----- <= anotherHelpTopic "Priority-based: ... -3 -2 -1 nil nil nil 1 2 3 4 ..." (self priority notNil and: [anotherHelpTopic priority notNil]) ifTrue: [^ self priority <= anotherHelpTopic priority]. (self priority notNil and: [anotherHelpTopic priority isNil]) ifTrue: [^ self priority <= 0]. (self priority isNil and: [anotherHelpTopic priority notNil]) ifTrue: [^ anotherHelpTopic priority >= 0]. "Fall-back." ^ self title <= anotherHelpTopic title! ----- Method: AbstractHelpTopic>>asHelpTopic (in category 'conversion') ----- asHelpTopic ^ self! ----- Method: AbstractHelpTopic>>contents (in category 'accessing') ----- contents "Return the text contents of this topic." self subclassResponsibility.! ----- Method: AbstractHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ self subtopics notEmpty! ----- Method: AbstractHelpTopic>>icon (in category 'accessing') ----- icon "Returns a descriptive form to support manual detection in a list of topics. Icons may encode the kind of topic." ^ nil! ----- Method: AbstractHelpTopic>>isEditable (in category 'testing') ----- isEditable ^ false! ----- Method: AbstractHelpTopic>>isSearchable (in category 'testing') ----- isSearchable ^ true! ----- Method: AbstractHelpTopic>>printOn: (in category 'printing') ----- printOn: stream | title | super printOn: stream. (title := self title) notNil ifTrue: [stream nextPutAll: '<' , title , '>'].! ----- Method: AbstractHelpTopic>>priority (in category 'accessing') ----- priority ^ nil! ----- Method: AbstractHelpTopic>>priorityForSearch (in category 'accessing') ----- priorityForSearch ^ 0! ----- Method: AbstractHelpTopic>>refresh (in category 'updating') ----- refresh "Do nothing."! ----- Method: AbstractHelpTopic>>subtopics (in category 'accessing') ----- subtopics "Topics can be nested in a tree structure." ^ #()! ----- Method: AbstractHelpTopic>>title (in category 'accessing') ----- title "A brief description of this topic's contents." ^ self contents truncateWithElipsisTo: 20! AbstractHelpTopic subclass: #ClassAPIHelpTopic instanceVariableNames: 'theClass withSubclasses withMethods subclassesAsSeparateTopic' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !ClassAPIHelpTopic commentStamp: 'mt 3/25/2015 15:03' prior: 0! Show comments of a class, their subclasses and methods.! ----- Method: ClassAPIHelpTopic>>contents (in category 'accessing') ----- contents ^ self theClass instanceSide organization classComment! ----- Method: ClassAPIHelpTopic>>icon (in category 'accessing') ----- icon ^ ToolIcons iconNamed: (ToolIcons iconForClass: self theClass name)! ----- Method: ClassAPIHelpTopic>>subclassesAsSeparateTopic (in category 'accessing') ----- subclassesAsSeparateTopic ^ subclassesAsSeparateTopic! ----- Method: ClassAPIHelpTopic>>subclassesAsSeparateTopic: (in category 'accessing') ----- subclassesAsSeparateTopic: aBoolean subclassesAsSeparateTopic := aBoolean.! ----- Method: ClassAPIHelpTopic>>subtopics (in category 'accessing') ----- subtopics ^ (self withMethods ifFalse: [#()] ifTrue: [ { MethodListHelpTopic new theClass: self theClass theNonMetaClass. MethodListHelpTopic new theClass: self theClass theMetaClass }]), (self withSubclasses ifFalse: [#()] ifTrue: [ | topics | topics := self theClass subclasses collect: [:cls | self class new theClass: cls; subclassesAsSeparateTopic: self subclassesAsSeparateTopic; withMethods: self withMethods; withSubclasses: self withSubclasses]. self subclassesAsSeparateTopic ifTrue: [{(HelpTopic named: 'Subclasses') subtopics: topics; yourself}] ifFalse: [topics]])! ----- Method: ClassAPIHelpTopic>>theClass (in category 'accessing') ----- theClass ^ theClass! ----- Method: ClassAPIHelpTopic>>theClass: (in category 'accessing') ----- theClass: aClassDescription theClass := aClassDescription.! ----- Method: ClassAPIHelpTopic>>title (in category 'accessing') ----- title ^ self theClass name! ----- Method: ClassAPIHelpTopic>>withMethods (in category 'accessing') ----- withMethods ^ withMethods ifNil:[false]! ----- Method: ClassAPIHelpTopic>>withMethods: (in category 'accessing') ----- withMethods: aBoolean withMethods := aBoolean.! ----- Method: ClassAPIHelpTopic>>withSubclasses (in category 'accessing') ----- withSubclasses ^ withSubclasses ifNil:[false]! ----- Method: ClassAPIHelpTopic>>withSubclasses: (in category 'accessing') ----- withSubclasses: aBoolean withSubclasses := aBoolean.! AbstractHelpTopic subclass: #ClassBasedHelpTopic instanceVariableNames: 'helpClass subtopics' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !ClassBasedHelpTopic commentStamp: 'mt 3/24/2015 16:28' prior: 0! This kind of topic uses subclasses and methods to encode books and pages.! ----- Method: ClassBasedHelpTopic>>contents (in category 'accessing') ----- contents "A book has no contents. Only its pages do." ^ ''! ----- Method: ClassBasedHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ self helpClass pages notEmpty or: [self helpClass subclasses notEmpty]! ----- Method: ClassBasedHelpTopic>>helpClass (in category 'accessing') ----- helpClass ^ helpClass! ----- Method: ClassBasedHelpTopic>>helpClass: (in category 'accessing') ----- helpClass: aHelpClass helpClass := aHelpClass.! ----- Method: ClassBasedHelpTopic>>icon (in category 'accessing') ----- icon ^ self helpClass icon! ----- Method: ClassBasedHelpTopic>>isEditable (in category 'testing') ----- isEditable ^ true! ----- Method: ClassBasedHelpTopic>>priority (in category 'accessing') ----- priority ^ self helpClass priority! ----- Method: ClassBasedHelpTopic>>refresh (in category 'updating') ----- refresh self updateSubtopics. self changed: #subtopicsUpdated.! ----- Method: ClassBasedHelpTopic>>subtopics (in category 'accessing') ----- subtopics ^ subtopics ifNil: [self updateSubtopics]! ----- Method: ClassBasedHelpTopic>>title (in category 'accessing') ----- title ^ self helpClass bookName! ----- Method: ClassBasedHelpTopic>>updateSubtopics (in category 'updating') ----- updateSubtopics | pages | pages := (self helpClass pages collect: [:pageSelectorOrClassName | (Smalltalk hasClassNamed: pageSelectorOrClassName asString) ifTrue: [Smalltalk classNamed: pageSelectorOrClassName asString] ifFalse: [pageSelectorOrClassName]]) asOrderedCollection. self helpClass subclasses select: [:cls | cls ignore not] thenDo: [:cls | pages addIfNotPresent: cls]. ^ subtopics := pages withIndexCollect: [:pageSelectorOrClass :priority | pageSelectorOrClass isBehavior ifFalse: [(self helpClass perform: pageSelectorOrClass) priority: priority - pages size; key: pageSelectorOrClass; yourself] ifTrue: [pageSelectorOrClass asHelpTopic]]! AbstractHelpTopic subclass: #HelpTopic instanceVariableNames: 'title key icon contents subtopics priority' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !HelpTopic commentStamp: 'mt 3/25/2015 11:27' prior: 0! This is a configurable version of a help topic. You can define its contents, title, icon, and subtopics manually. Help builders make use of this.! ----- Method: HelpTopic class>>named: (in category 'instance creation') ----- named: aString "Create a new instance with given title and empty contents" ^(self new) title: aString; yourself! ----- Method: HelpTopic class>>title:contents: (in category 'instance creation') ----- title: aTitle contents: aText "Create a new instance with given title and content" ^(self new) title: aTitle; contents: aText; yourself. ! ----- Method: HelpTopic class>>title:icon:contents: (in category 'instance creation') ----- title: aTitle icon: anIcon contents: aText "Create a new instance with given title, icon and content" ^(self new) title: aTitle; icon: anIcon; contents: aText; yourself. ! ----- Method: HelpTopic>>addSubtopic: (in category 'accessing') ----- addSubtopic: aTopic "Adds the given topic to the receivers collection of subtopics" self subtopics add: aTopic. self changed: #subtopicAdded with: aTopic. ^aTopic! ----- Method: HelpTopic>>contents (in category 'accessing') ----- contents "Returns the receivers contents" ^ contents! ----- Method: HelpTopic>>contents: (in category 'accessing') ----- contents: anObject "Sets the receivers contents to the given object" contents := anObject! ----- Method: HelpTopic>>defaultTitle (in category 'defaults') ----- defaultTitle "Returns the receivers default title" ^'Unnamed Topic' ! ----- Method: HelpTopic>>icon (in category 'accessing') ----- icon "Returns the receivers icon" ^icon! ----- Method: HelpTopic>>icon: (in category 'accessing') ----- icon: aSymbol "Sets the receivers icon" icon := aSymbol ! ----- Method: HelpTopic>>initialize (in category 'initialize-release') ----- initialize "Initializes the receiver" super initialize. self title: self defaultTitle. self contents: ''.! ----- Method: HelpTopic>>key (in category 'accessing') ----- key ^ key! ----- Method: HelpTopic>>key: (in category 'accessing') ----- key: aSymbol key := aSymbol.! ----- Method: HelpTopic>>priority (in category 'accessing') ----- priority "A hint for tools to influence sort order." ^ priority! ----- Method: HelpTopic>>priority: (in category 'accessing') ----- priority: anInteger priority := anInteger.! ----- Method: HelpTopic>>sortSubtopicsByTitle (in category 'operating') ----- sortSubtopicsByTitle "Sort the subtopics by title" subtopics := SortedCollection withAll: self subtopics ! ----- Method: HelpTopic>>subtopics (in category 'accessing') ----- subtopics "Returns the receivers list of subtopics" subtopics isNil ifTrue: [subtopics := OrderedCollection new]. ^subtopics! ----- Method: HelpTopic>>subtopics: (in category 'accessing') ----- subtopics: aCollection "Sets the receivers subtopics" subtopics := aCollection ! ----- Method: HelpTopic>>title (in category 'accessing') ----- title "Returns the receivers title" ^ title! ----- Method: HelpTopic>>title: (in category 'accessing') ----- title: anObject "Sets the receivers title" title := anObject! AbstractHelpTopic subclass: #HtmlHelpTopic instanceVariableNames: 'url document selectBlock convertBlock subtopicUrls subtopics level' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! ----- Method: HtmlHelpTopic>>contents (in category 'accessing') ----- contents | start end | start := (self document findString: '<body'). start := (self document findString: '>' startingAt: start) + 1. end := self document findString: '</body>' startingAt: start. start > end ifTrue: [^ self document]. ^ ((self document copyFrom: start to: end - 1) copyReplaceAll: String cr with: '<br>') asTextFromHtml! ----- Method: HtmlHelpTopic>>convertBlock (in category 'accessing') ----- convertBlock ^ convertBlock ifNil: [ [:aUrl | aUrl] ]! ----- Method: HtmlHelpTopic>>convertBlock: (in category 'accessing') ----- convertBlock: aBlock convertBlock := aBlock.! ----- Method: HtmlHelpTopic>>document (in category 'accessing') ----- document ^ document ifNil: [document := [ (HTTPSocket httpGet: self url accept: 'text/html') contents ] on: Error do: [:err | err printString]]! ----- Method: HtmlHelpTopic>>fetchSubtopics (in category 'caching') ----- fetchSubtopics "If this method is called from another process than the ui process, there will be no progress shown." | updateBlock | updateBlock := [:topic | topic document; subtopicUrls]. Project current uiProcess == Processor activeProcess ifFalse: [self subtopics do: updateBlock] ifTrue: [self subtopics do: updateBlock displayingProgress: [:topic | 'Fetching documents ... ', topic url]].! ----- Method: HtmlHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ self subtopicUrls notEmpty! ----- Method: HtmlHelpTopic>>isSearchable (in category 'testing') ----- isSearchable ^ self level < 2! ----- Method: HtmlHelpTopic>>level (in category 'accessing') ----- level ^ level ifNil: [level := 1]! ----- Method: HtmlHelpTopic>>level: (in category 'accessing') ----- level: anInteger level := anInteger.! ----- Method: HtmlHelpTopic>>priorityForSearch (in category 'accessing') ----- priorityForSearch ^ 999 "very late"! ----- Method: HtmlHelpTopic>>refresh (in category 'caching') ----- refresh "Re-fetch document and all referenced urls." document := nil. subtopics := nil. self changed: #contents. "See #contents. It is based on document." self changed: #subtopics.! ----- Method: HtmlHelpTopic>>selectBlock (in category 'accessing') ----- selectBlock ^ selectBlock ifNil: [ [:aUrl | true] ]! ----- Method: HtmlHelpTopic>>selectBlock: (in category 'accessing') ----- selectBlock: aBlock "Which urls should be followed?" selectBlock := aBlock.! ----- Method: HtmlHelpTopic>>subtopicUrls (in category 'accessing') ----- subtopicUrls ^ subtopicUrls ifNil: [ | start end | subtopicUrls := OrderedCollection new. start := self document findString: '<a '. start := self document findString: 'href' startingAt: start. [start > 0] whileTrue: [ start := self document findString: '"' startingAt: start. end := self document findString: '"' startingAt: start+1. subtopicUrls addIfNotPresent: (self document copyFrom: start+1 to: end-1). start := self document findString: '<a ' startingAt: end+1. start > 0 ifTrue: [start := self document findString: 'href' startingAt: start]]. subtopicUrls := subtopicUrls select: self selectBlock thenCollect: self convertBlock. subtopicUrls]! ----- Method: HtmlHelpTopic>>subtopics (in category 'accessing') ----- subtopics | start end urls | subtopics ifNotNil: [^ subtopics]. urls := OrderedCollection new. start := self document findString: '<a '. [start > 0] whileTrue: [ start := self document findString: 'href' startingAt: start. start := (self document findString: '"' startingAt: start) + 1. end := self document findString: '"' startingAt: start. urls addIfNotPresent: (self document copyFrom: start to: end - 1). start := self document findString: '<a ' startingAt: start.]. subtopics := (self subtopicUrls collect: [:aUrl | self class new level: self level + 1; url: aUrl; selectBlock: self selectBlock; convertBlock: self convertBlock]). Project current uiProcess == Processor activeProcess ifTrue: [self fetchSubtopics]. ^ subtopics! ----- Method: HtmlHelpTopic>>title (in category 'accessing') ----- title | start end | start := (self document findString: '<title') + 6. start := (self document findString: '>' startingAt: start) + 1. end := self document findString: '</title>' startingAt: start. start > end ifTrue: [^ self url asUrl authority]. ^ self document copyFrom: start to: end - 1! ----- Method: HtmlHelpTopic>>url (in category 'accessing') ----- url ^ url! ----- Method: HtmlHelpTopic>>url: (in category 'accessing') ----- url: aString url := aString.! AbstractHelpTopic subclass: #MethodListHelpTopic instanceVariableNames: 'theClass' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! ----- Method: MethodListHelpTopic>>contents (in category 'accessing') ----- contents ^ (String streamContents: [ :stream | self theClass selectors sort do: [ :selector | stream nextPutAll: self theClass name; nextPutAll: '>>'; nextPutAll: selector asString; cr; nextPutAll: ( (self theClass commentsAt: selector) at: 1 ifAbsent: [ '-' ]); cr; cr ] ])! ----- Method: MethodListHelpTopic>>icon (in category 'accessing') ----- icon ^ HelpIcons iconNamed: #pageIcon! ----- Method: MethodListHelpTopic>>priority (in category 'accessing') ----- priority ^ -999! ----- Method: MethodListHelpTopic>>theClass (in category 'accessing') ----- theClass ^ theClass! ----- Method: MethodListHelpTopic>>theClass: (in category 'accessing') ----- theClass: aClassOrMetaClass theClass := aClassOrMetaClass.! ----- Method: MethodListHelpTopic>>title (in category 'accessing') ----- title ^ self theClass isMeta ifTrue: ['Class side'] ifFalse: ['Instance side']! AbstractHelpTopic subclass: #PackageAPIHelpTopic instanceVariableNames: 'packageName' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !PackageAPIHelpTopic commentStamp: 'mt 3/25/2015 15:02' prior: 0! List all classes and their method comments. No subclasses.! ----- Method: PackageAPIHelpTopic>>contents (in category 'accessing') ----- contents ^ ''! ----- Method: PackageAPIHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ SystemOrganization categories anySatisfy: [:cat | (cat beginsWith: self packageName) and: [(SystemOrganization listAtCategoryNamed: cat) notEmpty]]! ----- Method: PackageAPIHelpTopic>>packageName (in category 'accessing') ----- packageName ^ packageName! ----- Method: PackageAPIHelpTopic>>packageName: (in category 'accessing') ----- packageName: aString packageName := aString.! ----- Method: PackageAPIHelpTopic>>subtopics (in category 'accessing') ----- subtopics ^ ((PackageInfo named: self packageName) classes sorted: [:cl1 :cl2 | cl1 name < cl2 name]) collect: [:class | ClassAPIHelpTopic new theClass: class; withSubclasses: false; withMethods: true]! ----- Method: PackageAPIHelpTopic>>title (in category 'accessing') ----- title ^ self packageName! AbstractHelpTopic subclass: #SearchTopic instanceVariableNames: 'term process results resultText topicsToSearch mutex updatePending' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! ----- Method: SearchTopic>><= (in category 'comparing') ----- <= anotherHelpTopic ^ true "Keep insertion order in parent topic."! ----- Method: SearchTopic>>contents (in category 'accessing') ----- contents ^ resultText ifNil: [self updateResultText]! ----- Method: SearchTopic>>find:in:results: (in category 'as yet unclassified') ----- find: term in: path results: results | resultTemplate c topic | topic := path last. resultTemplate := Array new: 5. (topic title asString findString: term startingAt: 1 caseSensitive: false) in: [:index | index > 0 ifTrue: [resultTemplate at: 2 put: (index to: index + term size)]]. ((c := topic contents asString withSqueakLineEndings) findString: term startingAt: 1 caseSensitive: false) in: [:index | index > 0 ifTrue: [ | leadingContext trailingContext i | leadingContext := 0. trailingContext := 0. i := index. [i notNil] whileTrue: [ (leadingContext = 2 or: [i = 1]) ifTrue: [ leadingContext := i = 1 ifTrue: [i] ifFalse: [i+1]. i := nil] ifFalse: [ ((c at: i) = Character cr) ifTrue: [ leadingContext := leadingContext + 1]. i := i - 1] ]. i := index + term size. [i notNil] whileTrue: [ (trailingContext = 2 or: [i = c size]) ifTrue: [ trailingContext := i = c size ifTrue: [i] ifFalse: [i-1]. i := nil] ifFalse: [ ((c at: i) = Character cr) ifTrue: [ trailingContext := trailingContext + 1]. i := i + 1] ]. resultTemplate at: 1 put: path; at: 3 put: (index - leadingContext + 1 to: index - leadingContext + term size); at: 4 put: (c copyFrom: leadingContext to: trailingContext); at: 5 put: leadingContext. self mutex critical: [ results add: resultTemplate ]. self triggerUpdateContents. ] ]. topic isSearchable ifTrue: [ topic subtopics do: [:t | self find: term in: path, {t} results: results]].! ----- Method: SearchTopic>>mutex (in category 'as yet unclassified') ----- mutex ^ mutex ifNil: [mutex := Mutex new]! ----- Method: SearchTopic>>printResultEntry: (in category 'as yet unclassified') ----- printResultEntry: entry | resultEntry topic | resultEntry := '' asText. topic := entry first last. entry second notNil ifFalse: [resultEntry append: ( (topic title) asText addAttribute: TextEmphasis bold)] ifTrue: [resultEntry append: ( (topic title) asText addAttribute: TextEmphasis bold; addAttribute: (TextColor color: Color green muchDarker) from: entry second first to: entry second last)]. resultEntry append: (' (open topic)' asText addAttribute: (PluggableTextAttribute evalBlock: [self changed: #searchResultSelected with: entry first])). resultEntry append: String cr. entry fourth in: [:contents | | text | text := contents asText. text addAttribute: (TextColor color: Color green muchDarker) from: entry third first to: entry third last; addAttribute: TextEmphasis bold from: entry third first to: entry third last. resultEntry append: text withBlanksTrimmed; append: '\\' withCRs. ]. ^ resultEntry! ----- Method: SearchTopic>>startSearch (in category 'as yet unclassified') ----- startSearch self stopSearch. results := OrderedCollection new. self topicsToSearch ifEmpty: [ self changed: #contents. ^ self]. process := [ (self topicsToSearch sorted: [:t1 :t2 | t1 priorityForSearch <= t2 priorityForSearch]) do: [:topic | | nestedResults | nestedResults := OrderedCollection new. self mutex critical: [results add: topic -> nestedResults]. self find: self term in: {topic} results: nestedResults]. results add: 'Search finished.'. self triggerUpdateContents. ] forkAt: 35.! ----- Method: SearchTopic>>stopSearch (in category 'as yet unclassified') ----- stopSearch process ifNotNil: #terminate. process := nil.! ----- Method: SearchTopic>>term (in category 'accessing') ----- term ^ term! ----- Method: SearchTopic>>term: (in category 'accessing') ----- term: aString term := aString.! ----- Method: SearchTopic>>title (in category 'accessing') ----- title ^ '''', self term, ''''! ----- Method: SearchTopic>>topicsToSearch (in category 'accessing') ----- topicsToSearch ^ topicsToSearch ifNil: [#()]! ----- Method: SearchTopic>>topicsToSearch: (in category 'accessing') ----- topicsToSearch: someTopics topicsToSearch := someTopics.! ----- Method: SearchTopic>>triggerUpdateContents (in category 'as yet unclassified') ----- triggerUpdateContents self mutex critical: [ updatePending == true ifFalse: [ updatePending := true. Project current addDeferredUIMessage: [ActiveWorld addAlarm: #updateContents withArguments: #() for: self at: Time millisecondClockValue + 250] ] ]. ! ----- Method: SearchTopic>>updateContents (in category 'as yet unclassified') ----- updateContents self mutex critical: [ updatePending := false ]. resultText := nil. self changed: #contents with: self.! ----- Method: SearchTopic>>updateResultText (in category 'as yet unclassified') ----- updateResultText resultText := '' asText. self mutex critical: [ results ifNil: [^ resultText]. results do: [:topicToResult | topicToResult isString ifTrue: [resultText append: ( (topicToResult, String cr) asText addAttribute: (TextColor color: (Color gray: 0.7)); yourself)] ifFalse: [ resultText append: ( ('\----- Matches found in ''', topicToResult key title, ''' -----\\') withCRs asText addAttribute: (TextColor color: (Color gray: 0.7))). topicToResult value do: [:entry | resultText append: (self printResultEntry: entry)] ]]]. ^ resultText! Model subclass: #HelpBrowser instanceVariableNames: 'rootTopic currentTopic currentParentTopic result searchTopic topicPath toplevelTopics oldTopic' classVariableNames: 'DefaultHelpBrowser' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpBrowser commentStamp: 'tbn 3/8/2010 09:33' prior: 0! A HelpBrowser is used to display a hierarchy of help topics and their contents. Instance Variables rootTopic: <HelpTopic> window: <StandardWindow> treeMorph: <PluggableTreeMorph> contentMorph: <Morph> rootTopic - xxxxx window - xxxxx treeMorph - xxxxx contentMorph - xxxxx ! ----- Method: HelpBrowser class>>defaultHelpBrowser (in category 'accessing') ----- defaultHelpBrowser DefaultHelpBrowser isNil ifTrue: [DefaultHelpBrowser := self]. ^DefaultHelpBrowser ! ----- Method: HelpBrowser class>>defaultHelpBrowser: (in category 'accessing') ----- defaultHelpBrowser: aClass "Use a new help browser implementation" DefaultHelpBrowser := aClass ! ----- Method: HelpBrowser class>>initialize (in category 'class initialization') ----- initialize "Initializes the receiver class" TheWorldMenu registerOpenCommand: {'Help Browser'. {self. #open}}. ! ----- Method: HelpBrowser class>>open (in category 'instance creation') ----- open ^self openOn: CustomHelp! ----- Method: HelpBrowser class>>openOn: (in category 'instance creation') ----- openOn: aHelpTopic "Open the receiver on the given help topic or any other object that can be transformed into a help topic by sending #asHelpTopic." ^(self defaultHelpBrowser new) open; rootTopic: aHelpTopic; yourself! ----- Method: HelpBrowser>>accept: (in category 'actions') ----- accept: text "Accept edited text. Compile it into a HelpTopic" | code parent topicClass topicMethod | (self currentParentTopic isNil or: [self currentParentTopic isEditable not]) ifTrue: [^ self inform: 'This help topic cannot be edited.']. parent := self currentParentTopic. topicClass := parent helpClass. topicMethod := self currentTopic key. code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). parent refresh. self currentTopic: (parent subtopics detect: [:t | t key = topicMethod]).! ----- Method: HelpBrowser>>buildWith: (in category 'toolbuilder') ----- buildWith: builder | windowSpec treeSpec textSpec searchSpec | windowSpec := builder pluggableWindowSpec new. windowSpec model: self; children: OrderedCollection new; label: #label. searchSpec := builder pluggableInputFieldSpec new. searchSpec model: self; getText: #searchTerm; setText: #searchTerm:; help: 'Search...'; frame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (Preferences standardDefaultTextFont height * 2))). windowSpec children add: searchSpec. treeSpec := builder pluggableTreeSpec new. treeSpec model: self; nodeClass: HelpTopicListItemWrapper; roots: #toplevelTopics; getSelected: #currentTopic; setSelected: #currentTopic:; getSelectedPath: #currentTopicPath; setSelectedParent: #currentParentTopic:; autoDeselect: false; frame: (LayoutFrame fractions: (0@0 corner: 0.3@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)). windowSpec children add: treeSpec. textSpec := builder pluggableTextSpec new. textSpec model: self; getText: #topicContents; setText: #accept:; menu: #codePaneMenu:shifted:; frame: (LayoutFrame fractions: (0.3(a)0.0 corner: 1@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)). windowSpec children add: textSpec. ^ builder build: windowSpec! ----- Method: HelpBrowser>>codePaneMenu:shifted: (in category 'events') ----- codePaneMenu: aMenu shifted: shifted ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted ! ----- Method: HelpBrowser>>currentParentTopic (in category 'accessing') ----- currentParentTopic ^ currentParentTopic! ----- Method: HelpBrowser>>currentParentTopic: (in category 'accessing') ----- currentParentTopic: aHelpTopic currentParentTopic := aHelpTopic.! ----- Method: HelpBrowser>>currentTopic (in category 'accessing') ----- currentTopic ^ currentTopic! ----- Method: HelpBrowser>>currentTopic: (in category 'accessing') ----- currentTopic: aHelpTopic self currentTopic == aHelpTopic ifTrue: [^ self]. currentTopic := aHelpTopic. topicPath := nil. self changed: #currentTopic. self changed: #topicContents.! ----- Method: HelpBrowser>>currentTopicPath (in category 'accessing') ----- currentTopicPath "Only used for dynamic dispatch. Should be nil or empty on manual evaluation. See #topic:." ^ topicPath ifNil: [#()]! ----- Method: HelpBrowser>>currentTopicPath: (in category 'accessing') ----- currentTopicPath: someTopics "Use the tree structure to select a nested topic." topicPath := someTopics. self changed: #currentTopicPath.! ----- Method: HelpBrowser>>find (in category 'actions') ----- find "Prompt the user for a string to search for, and search the receiver from the current selection onward for it." | reply | reply := UIManager default request: 'Find what? ' initialAnswer: ''. reply size = 0 ifTrue: [ ^ self]. self findStringInHelpTopic: reply ! ----- Method: HelpBrowser>>find: (in category 'actions') ----- find: aString ^SystemNavigation allMethodsSelect: [:method | method hasLiteralSuchThat: [:lit | (lit isString and: [lit isSymbol not]) and: [lit includesSubstring: aString caseSensitive: false]]] localTo: CustomHelp ! ----- Method: HelpBrowser>>findAgain (in category 'actions') ----- findAgain | i | (i := result indexOf: currentTopic) ~= 0 ifTrue: [i = result size ifTrue: [(self confirm: 'Start over?') ifTrue: [i := 1] ifFalse: [^ self]]. self onItemClicked: (result at: i + 1)]! ----- Method: HelpBrowser>>findStringInHelpTopic: (in category 'actions') ----- findStringInHelpTopic: aString result := OrderedCollection new. self inSubtopic: self rootTopic find: aString. result ifNotEmpty: [self topic: result first]. ! ----- Method: HelpBrowser>>inSubtopic:find: (in category 'actions') ----- inSubtopic: aTopic find: aString ((aTopic title asString includesSubstring: aString caseSensitive: false) or: [aTopic contents asString includesSubstring: aString caseSensitive: false]) ifTrue: [result addIfNotPresent: aTopic]. aTopic subtopics do: [:sub | self inSubtopic: sub find: aString]! ----- Method: HelpBrowser>>inTopic:replaceCurrentTopicWith: (in category 'actions') ----- inTopic: parentTopic replaceCurrentTopicWith: aNewTopic parentTopic subtopics do: [ :sub | self inTopic: parentTopic replaceSubtopic: sub with: aNewTopic]! ----- Method: HelpBrowser>>inTopic:replaceSubtopic:with: (in category 'actions') ----- inTopic: parentTopic replaceSubtopic: aTopic with: aNewTopic | i | (aTopic = oldTopic) ifTrue: [ i := parentTopic subtopics indexOf: aTopic. parentTopic subtopics at: i put: aNewTopic. ^self ]. aTopic subtopics do: [ :sub | self inTopic: aTopic replaceSubtopic: sub with: aNewTopic]! ----- Method: HelpBrowser>>label (in category 'accessing - ui') ----- label ^ self rootTopic ifNil: ['Help Browser'] ifNotNil: [:topic | topic title]! ----- Method: HelpBrowser>>menu: (in category 'events') ----- menu: aMenu ^aMenu add: 'find...' translated action: #find. ! ----- Method: HelpBrowser>>open (in category 'ui') ----- open ToolBuilder open: self.! ----- Method: HelpBrowser>>rootTopic (in category 'accessing') ----- rootTopic ^rootTopic! ----- Method: HelpBrowser>>rootTopic: (in category 'accessing') ----- rootTopic: aHelpTopic rootTopic := aHelpTopic asHelpTopic. self toplevelTopics: ((self rootTopic ifNil: [#()] ifNotNil: #subtopics) sorted, {self searchTopic}). self changed: #label.! ----- Method: HelpBrowser>>searchTerm (in category 'searching') ----- searchTerm ^ '' "Reset. Terms are cached in SearchTopic instances."! ----- Method: HelpBrowser>>searchTerm: (in category 'searching') ----- searchTerm: aString "Spawn a new search topic." | topic | topic := self searchTopic subtopics detect: [:t | t term = aString] ifNone: [ | newTopic | newTopic := SearchTopic new term: aString; yourself. self searchTopic addSubtopic: newTopic. newTopic addDependent: self. "Tell me about your updates." newTopic]. "self changed: #searchTerm." "Select results and expand searches node if necessary." self currentTopicPath: {self searchTopic. topic}. self assert: self currentTopic == topic. topic topicsToSearch: self toplevelTopics allButLast; startSearch.! ----- Method: HelpBrowser>>searchTopic (in category 'searching') ----- searchTopic ^ searchTopic ifNil: [searchTopic := HelpTopic new title: 'Search Results'; addDependent: self; yourself]! ----- Method: HelpBrowser>>topicContents (in category 'accessing - ui') ----- topicContents ^ (self currentTopic ifNil: [self rootTopic]) ifNil: '' ifNotNil: #contents! ----- Method: HelpBrowser>>toplevelTopics (in category 'accessing') ----- toplevelTopics ^ toplevelTopics ifNil: [#()]! ----- Method: HelpBrowser>>toplevelTopics: (in category 'accessing') ----- toplevelTopics: someTopics toplevelTopics := someTopics. self changed: #toplevelTopics.! ----- Method: HelpBrowser>>update:with: (in category 'updating') ----- update: aspect with: object aspect == #contents ifTrue: [ object == self currentTopic ifTrue: [self changed: #topicContents]]. aspect == #searchResultSelected ifTrue: [ self currentTopicPath: object].! ----- Method: HelpBrowser>>windowIsClosing (in category 'updating') ----- windowIsClosing super windowIsClosing. self searchTopic subtopics do: [:topic | topic stopSearch].! PluggableListItemWrapper subclass: #HelpTopicListItemWrapper instanceVariableNames: 'parent' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpTopicListItemWrapper commentStamp: 'tbn 3/8/2010 09:30' prior: 0! This class implements a list item wrapper for help topics. Instance Variables ! ----- Method: HelpTopicListItemWrapper class>>with:model:parent: (in category 'as yet unclassified') ----- with: anObject model: aModel parent: aParent ^self new setItem: anObject model: aModel parent: aParent ! ----- Method: HelpTopicListItemWrapper>>asString (in category 'accessing') ----- asString "Returns a string used as a label" ^ self item title! ----- Method: HelpTopicListItemWrapper>>balloonText (in category 'accessing') ----- balloonText "Returns a string used for fly by help" ^self item title! ----- Method: HelpTopicListItemWrapper>>contents (in category 'accessing') ----- contents ^self item subtopics sorted collect: [ :each | HelpTopicListItemWrapper with: each model: self model parent: self] ! ----- Method: HelpTopicListItemWrapper>>hasContents (in category 'accessing') ----- hasContents ^ self item hasSubtopics! ----- Method: HelpTopicListItemWrapper>>icon (in category 'accessing') ----- icon "Either return the icon for the given topic" | symbol | self item icon ifNotNil: [:icon | ^ icon]. symbol := self item hasSubtopics ifTrue: [#bookIcon] ifFalse: [#pageIcon]. ^HelpIcons iconNamed: symbol! ----- Method: HelpTopicListItemWrapper>>item (in category 'accessing') ----- item ^ super item ifNil: [HelpTopic new]! ----- Method: HelpTopicListItemWrapper>>parent (in category 'accessing') ----- parent ^ parent! ----- Method: HelpTopicListItemWrapper>>parent: (in category 'accessing') ----- parent: aWrapper parent := aWrapper.! ----- Method: HelpTopicListItemWrapper>>setItem:model:parent: (in category 'initialization') ----- setItem: anObject model: aModel parent: itemParent self parent: itemParent. self setItem: anObject model: aModel.! ----- Method: HelpTopicListItemWrapper>>update: (in category 'accessing') ----- update: aspect super update: aspect. "Map the domain-specific aspect to a framework-specific one." aspect = #subtopicsUpdated ifTrue: [ self changed: #contents].! ----- Method: HelpTopicListItemWrapper>>update:with: (in category 'accessing') ----- update: aspect with: object super update: aspect with: object. "Map the domain-specific aspect to a framework-specific one." aspect = #subtopicAdded ifTrue: [ self changed: #contents].! Object subclass: #CustomHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Utilities'! !CustomHelp commentStamp: 'tbn 3/29/2010 13:23' prior: 0! This is a common superclass for custom help. Subclasses of this class are automatically included into the system help. By default the informations provided on the receiver class are converted into help topics by a specific builder - here the CustomHelpHelpBuilder. Note that you can provide an own custom builder by overriding the #builder method ! ----- Method: CustomHelp class>>accept:title:contents: (in category 'editing') ----- accept: aSelector title: title contents: text "Accept edited text. Compile it into a HelpTopic" | code | code := String streamContents:[:s| s nextPutAll: aSelector. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', aSelector storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. self class compile: code classified: ((self class organization categoryOfElement: aSelector) ifNil:['pages']). ! ----- Method: CustomHelp class>>asHelpTopic (in category 'converting') ----- asHelpTopic "Convert the receiver to a help topic" ^ ClassBasedHelpTopic new helpClass: self! ----- Method: CustomHelp class>>bookName (in category 'accessing') ----- bookName "Returns the name of the custom help book" ^'Help'! ----- Method: CustomHelp class>>edit: (in category 'editing') ----- edit: aSelector "Open a Workspace on the text in the given selector. When accepted, compile the result as a help topic." | topic window | topic := (self respondsTo: aSelector) ifTrue:[self perform: aSelector] ifFalse:[HelpTopic title: 'Untitled' contents: 'Please edit this topic. To change the topic title, edit the window label.']. window := UIManager default edit: topic contents label: topic title accept: [:text| self accept: aSelector title: window label contents: text]. ! ----- Method: CustomHelp class>>icon (in category 'accessing') ----- icon "Returns an icon used for displaying the custom help book" ^HelpIcons iconNamed: #bookIcon! ----- Method: CustomHelp class>>ignore (in category 'accessing') ----- ignore ^ false! ----- Method: CustomHelp class>>pages (in category 'accessing') ----- pages "Returns a collection of method selectors to return the pages of the custom help book" ^#()! ----- Method: CustomHelp class>>priority (in category 'accessing') ----- priority ^ nil! CustomHelp subclass: #HelpOnHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! !HelpOnHelp commentStamp: 'dtl 11/13/2014 19:20' prior: 0! HelpOnHelp is documentation for the help system! HelpOnHelp subclass: #HelpAPIDocumentation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! !HelpAPIDocumentation commentStamp: 'tbn 4/30/2010 15:12' prior: 0! This class represents the browsable package API help for the help system. Instance Variables ! ----- Method: HelpAPIDocumentation class>>asHelpTopic (in category 'defaults') ----- asHelpTopic ^ (HelpTopic named: self bookName) subtopics: (self packages collect: [:pkgName | PackageAPIHelpTopic new packageName: pkgName]); yourself! ----- Method: HelpAPIDocumentation class>>bookName (in category 'accessing') ----- bookName ^'API Documentation'! ----- Method: HelpAPIDocumentation class>>packages (in category 'accessing') ----- packages ^#('HelpSystem-Core-Model' 'HelpSystem-Core-Utilities' 'HelpSystem-Core-UI')! HelpOnHelp subclass: #HelpHowToHelpTopics instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! ----- Method: HelpHowToHelpTopics class>>bookName (in category 'accessing') ----- bookName ^'Implementation'! ----- Method: HelpHowToHelpTopics class>>overview (in category 'pages') ----- overview ^HelpTopic title: 'Overview' contents: 'THE IMPLEMENTATION The help system typically consists of help books including one or more pages. A book or page is therefore a "topic of interest" providing contents for help to a user. A topic has a title and an icon and is able to have subtopics forming a hierarchy of topics. This simple model is reflected in the class HelpTopic. Since this model forms a hierarchical structure of help topics there is a browser with a tree to display the help contents. This browser is implemented in class HelpBrowser. You can open this browser programmatically using: HelpBrowser open ' ! ----- Method: HelpHowToHelpTopics class>>page1 (in category 'pages') ----- page1 ^HelpTopic title: '1. Simple help topics' contents: 'The help browser usually operates on a hierarchy of help topics with one help topic at the root level. Evaluate the following expression in a workspace to contruct a simple help topic and open it as a root topic in the help browser. |root| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. HelpBrowser openOn: root Note that the help browser displays the contents of our topic in the right page and uses the topics title as the title for the help browser window. '! ----- Method: HelpHowToHelpTopics class>>page2 (in category 'pages') ----- page2 ^HelpTopic title: '2. Forming a hierarchy' contents: 'To form a hierarchy we just have to add new subtopics on our root topic. |root sub1 sub2| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. sub1 := HelpTopic title: ''My first subtopic'' contents: ''First subsection''. sub2 := HelpTopic title: ''My second subtopic'' contents: ''Second subsection''. root addSubtopic: sub1; addSubtopic: sub2. HelpBrowser openOn: root '! ----- Method: HelpHowToHelpTopics class>>page3 (in category 'pages') ----- page3 ^HelpTopic title: '3. Adding icons' contents: 'If you dont like the default icon you can add own custom icons to the topics. See the class HelpIcons for more details. |root sub1 sub2| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. sub1 := HelpTopic title: ''My first subtopic'' contents: ''First subsection''. sub2 := HelpTopic title: ''My second subtopic'' icon: (HelpIcons iconNamed: #packageIcon) contents: ''Second subsection''. root addSubtopic: sub1; addSubtopic: sub2. HelpBrowser openOn: root '! ----- Method: HelpHowToHelpTopics class>>page4 (in category 'pages') ----- page4 ^HelpTopic title: '4. Own help objects' contents: 'You can open this help browser directly on an instance of HelpTopic, but it is more common to open it on any object that understands the message #asHelpTopic. So you can write for instance: HelpBrowser openOn: Integer opening a short API help/system reference on the Integer class. The above expression is the short form for: HelpBrowser openOn: (SystemReference forClass: Integer) If you want you can include the subclasses: HelpBrowser openOn: (SystemReference hierarchyFor: Integer) or even methods HelpBrowser openOn: (SystemReference hierarchyWithMethodsFor: Integer) You can browse the whole system reference documentation using: HelpBrowser openOn: SystemReference But these are only a few examples what we can extract from the system. However - the major goal is NOT an API browser, the idea is to provide a simple architecture to provide browsable help contents depending on the context. For instance it should also be possible to use the help system to provide end user help on any commercial application that is written with the Smalltalk system. ' ! ----- Method: HelpHowToHelpTopics class>>page5 (in category 'pages') ----- page5 ^HelpTopic title: '5. Help sources' contents: 'Since the underlying model is very simple you can easily fill it with nearly any information from different sources. Try this: |topic day url sub| topic := HelpTopic named: ''Last week on Squeak IRC''. 0 to: 7 do: [:index | day := (Date today subtractDays: index) printFormat: #(3 2 1 $. 1 2 2). url := ''http://tunes.org/~nef/logs/squeak/'' , day. sub := HelpTopic title: day contents: (HTTPLoader default retrieveContentsFor: url) contents. topic addSubtopic: sub. ]. HelpBrowser openOn: topic ' ! ----- Method: HelpHowToHelpTopics class>>pages (in category 'accessing') ----- pages ^#(overview page1 page2 page3 page4 page5)! HelpHowToHelpTopics subclass: #HelpHowToHelpTopicsFromCode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! ----- Method: HelpHowToHelpTopicsFromCode class>>bookName (in category 'accessing') ----- bookName ^'Custom help from code'! ----- Method: HelpHowToHelpTopicsFromCode class>>overview (in category 'pages') ----- overview ^HelpTopic title: 'Overview' contents: 'OVERVIEW The help system allows you to provide own books and help texts. You can open the help browser on any object that is able to understand #asHelpTopic. This method returns the root node of the displayed topic hierarchy: HelpBrowser openOn: myObject Typically the object does not convert itself to a help topic structure, usually it dispatches to a builder (see HelpBuilder and subclasses) who does all this. A much more convenient and reproducable way is to implement custom help classes. This allows you to implement and manage your help texts using the standard development and code management tools. These custom help classes are subclasses of "CustomHelp" and are automatically included into the standard help browser. '! ----- Method: HelpHowToHelpTopicsFromCode class>>pages (in category 'accessing') ----- pages ^#(overview step1 step2 step3 step4 step5 step6 step7)! ----- Method: HelpHowToHelpTopicsFromCode class>>step1 (in category 'pages') ----- step1 ^HelpTopic title: 'Step 1 - Create a class for the book' contents: 'STEP 1 - CREATE A CLASS FOR THE BOOK There is a predefined class CustomHelp which you have to subclass for a custom help book to show up as a book in the Help browser: CustomHelp subclass: #MyAppHelp instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Help'' Class methods on this class can reflect pages and if you want to provide nested help books just subclass your own help class to form a hierarchy. Any new subclass of MyAppHelp will then be a new book in your hierarchy. The class category used should end with "-Help" so it is easy to recognize that it includes the help support of your project.' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step2 (in category 'pages') ----- step2 ^HelpTopic title: 'Step 2 - Provide a book name' contents: 'STEP 2 - PROVIDE A BOOK NAME Now implement the class method #bookName to return the name of your help book. bookName ^''My App help'' By implementing this method the system knows how you would like to name your book and uses the given string as a label in the HelpBrowser later.' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step3 (in category 'pages') ----- step3 ^HelpTopic title: 'Step 3 - Implement pages using methods' contents: 'STEP 3 - IMPLEMENT PAGES USING METHODS Implement a page by defining a method that returns an instance of HelpPage defining a page title and a help text displayed in the help browser. firstPage ^HelpTopic title: ''First Page'' contents: ''Hello world'' Define a new method for each page of your book. Please group the pages in a method category called "pages". You can also define an icon for the specific page: secondPage ^HelpTopic title: ''Second Page'' icon: (HelpIcons iconNamed: #packageIcon) contents: ''More to come'' Note: ===== Later we may add support for better help contents than just plain text (markup descriptions, active morphs, ...) ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step4 (in category 'pages') ----- step4 ^HelpTopic title: 'Step 4 - Defining the page order' contents: 'STEP 4 - DEFINING THE PAGE ORDER By implementing the class method #pages you return a collection of method selectors to define the order in which the pages appear in your book: pages ^#(firstPage secondPage) ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step5 (in category 'pages') ----- step5 ^HelpTopic title: 'Step 5 - Test your help' contents: 'STEP 5 - TEST YOUR HELP By using HelpBrowser open ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step6 (in category 'pages') ----- step6 ^HelpTopic title: 'Step 6 - Add more structure' contents: 'STEP 6 - ADD MORE STRUCTURE If you add a new subclass to your custom help class and repeating step 2 to 4 you can profide new substructures (subbooks) since the help books are mapped to the class hierarchy. Example: MyAppHelp subclass: #MyAppTutorial instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Help'' then implement a #bookName, the pages and a #pages method as before on this new class and reopen the help browser. ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step7 (in category 'pages') ----- step7 ^HelpTopic title: 'Step 7 - Tips and Tricks' contents: 'STEP 7 - TIPS AND TRICKS Tip1: If you implement the #pages method you can also use the name of a custom help class that should be integrated between the specific pages: #pages ^(firstPage MyAppTutorial secondPage) Tip2: You can easily edit the help contents of a page by using the #edit: message. For our example just evaluate: MyAppHelp edit: #firstPage This will open a workspace with the help contents and when you accept it it will be saved back to the help method defining the topic. ' ! ----- Method: HelpOnHelp class>>bookName (in category 'accessing') ----- bookName ^'Help on Help'! ----- Method: HelpOnHelp class>>introduction (in category 'pages') ----- introduction "This method was automatically generated. Edit it using:" "HelpOnHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'WELCOME TO THE HELP SYSTEM The help system is a simple user interface to display help contents to the user. It can be accessed from the world menu using "Tools" -> "Help Browser" or by evaluating ''HelpBrowser open'' in a workspace. There is a predefined mechanism allowing you to have help contents stored as source code using methods in specific help provider classes. This allows you to manage the help texts using the standard development tools. But this is only one possible representation. !!' readStream nextChunkText! ----- Method: HelpOnHelp class>>pages (in category 'accessing') ----- pages ^#(introduction HelpHowToHelpTopics HelpAPIDocumentation)! ----- Method: HelpOnHelp class>>priority (in category 'accessing') ----- priority ^ 9999 "at the bottom"! Object subclass: #HelpBuilder instanceVariableNames: 'topicToBuild rootToBuildFrom' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !HelpBuilder commentStamp: 'tbn 2/12/2010 14:54' prior: 0! This is an utility class that builds the books for a help system. Instance Variables rootTopics: <OrderedCollection> rootTopics - a collection of books ! HelpBuilder subclass: #ClassAPIHelpBuilder instanceVariableNames: 'addSubclasses addMethods subclassesAsSeparateTopic' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !ClassAPIHelpBuilder commentStamp: 'tbn 4/30/2010 15:37' prior: 0! A builder to build the API Help for a class Instance Variables addMethods: <Boolean> addSubclasses: <Boolean> subclassesAsSeparateTopic: <Boolean> addMethods - When true the builder will include method help addSubclasses - When true the builder will recursively go through and add subclasses subclassesAsSeparateTopic - xxxxx ! ----- Method: ClassAPIHelpBuilder class>>buildHierarchicalHelpTopicFrom:withSubclasses:withMethods: (in category 'building') ----- buildHierarchicalHelpTopicFrom: aClass withSubclasses: aBoolean withMethods: anotherBoolean "Start building from the given class" ^(self new) addSubclasses: aBoolean; addMethods: anotherBoolean; rootToBuildFrom: aClass; build; topicToBuild ! ----- Method: ClassAPIHelpBuilder>>addMethods (in category 'accessing') ----- addMethods ^ addMethods! ----- Method: ClassAPIHelpBuilder>>addMethods: (in category 'accessing') ----- addMethods: anObject addMethods := anObject! ----- Method: ClassAPIHelpBuilder>>addSubclasses (in category 'accessing') ----- addSubclasses ^ addSubclasses! ----- Method: ClassAPIHelpBuilder>>addSubclasses: (in category 'accessing') ----- addSubclasses: anObject addSubclasses := anObject! ----- Method: ClassAPIHelpBuilder>>build (in category 'building') ----- build CurrentReadOnlySourceFiles cacheDuring: [ topicToBuild := (HelpTopic named: rootToBuildFrom name). topicToBuild icon: (HelpIcons iconNamed: #pageIcon). topicToBuild contents: rootToBuildFrom comment. addMethods ifTrue: [ self buildSubnodesForMethods ]. addSubclasses ifTrue: [ self buildSubnodesForSubclasses ] ]. ! ----- Method: ClassAPIHelpBuilder>>buildMethodTopicsOn:for: (in category 'private building') ----- buildMethodTopicsOn: topic for: aClass topic contents: (String streamContents: [ :stream | aClass selectors sort do: [ :selector | stream nextPutAll: aClass name; nextPutAll: '>>'; nextPutAll: selector asString; cr; nextPutAll: ( (aClass commentsAt: selector) at: 1 ifAbsent: [ 'Method has no comment.' ]); cr; cr ] ])! ----- Method: ClassAPIHelpBuilder>>buildSubclassTopicFor: (in category 'private building') ----- buildSubclassTopicFor: aSubclass ^(self class new) rootToBuildFrom: aSubclass; addSubclasses: addSubclasses; addMethods: addMethods; subclassesAsSeparateTopic: subclassesAsSeparateTopic; build; topicToBuild ! ----- Method: ClassAPIHelpBuilder>>buildSubnodesForMethods (in category 'private building') ----- buildSubnodesForMethods | instanceSide classSide | instanceSide := HelpTopic named: 'Instance side'. classSide := HelpTopic named: 'Class side'. topicToBuild icon: (HelpIcons iconNamed: #bookIcon). topicToBuild addSubtopic: instanceSide; addSubtopic: classSide. self buildMethodTopicsOn: instanceSide for: rootToBuildFrom. self buildMethodTopicsOn: classSide for: rootToBuildFrom class. ! ----- Method: ClassAPIHelpBuilder>>buildSubnodesForSubclasses (in category 'private building') ----- buildSubnodesForSubclasses | topic | rootToBuildFrom subclasses isEmpty ifTrue: [^self]. topicToBuild icon: (HelpIcons iconNamed: #bookIcon). topic := subclassesAsSeparateTopic ifTrue: [topicToBuild addSubtopic: (HelpTopic named: 'Subclasses')] ifFalse: [topicToBuild ]. rootToBuildFrom subclasses do: [:subclass | topic addSubtopic: (self buildSubclassTopicFor: subclass)]. topic sortSubtopicsByTitle. ! ----- Method: ClassAPIHelpBuilder>>initialize (in category 'initialize-release') ----- initialize "Initializes the receiver" super initialize. addSubclasses := false. addMethods := true. subclassesAsSeparateTopic := true.! ----- Method: ClassAPIHelpBuilder>>subclassesAsSeparateTopic (in category 'accessing') ----- subclassesAsSeparateTopic ^ subclassesAsSeparateTopic! ----- Method: ClassAPIHelpBuilder>>subclassesAsSeparateTopic: (in category 'accessing') ----- subclassesAsSeparateTopic: anObject subclassesAsSeparateTopic := anObject! HelpBuilder subclass: #CustomHelpHelpBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !CustomHelpHelpBuilder commentStamp: 'tbn 3/29/2010 13:30' prior: 0! This builder builds help topics from a help topic description (which is typically stored in a class). The help topic description object has to understand the following messages: #bookName - should return the name of the help book #icon - should return the icon of the help book #key - should return a unique key to identify the book #pages - should return an array of method selectors to call to get the books pages ! ----- Method: CustomHelpHelpBuilder>>build (in category 'building') ----- build "Start building a help topic from a code description" topicToBuild := self createTopicFrom: rootToBuildFrom ! ----- Method: CustomHelpHelpBuilder>>createTopicFrom: (in category 'private') ----- createTopicFrom: aDescription "Create a topic from a description stored on a class. aDescription can specify (via #pages) the name of a class and not only a selector. This allows for hierarchies with 'subtrees in the middle'" |topic page pageClasses | topic := HelpTopic named: aDescription bookName. topic key: aDescription key. topic icon: aDescription icon. pageClasses := Set new. aDescription pages do: [:pageSelectorOrClass| page:= (Smalltalk hasClassNamed: pageSelectorOrClass asString) ifFalse: [aDescription perform: pageSelectorOrClass] ifTrue: [pageClasses add: (Smalltalk classNamed: pageSelectorOrClass asString). (Smalltalk classNamed: pageSelectorOrClass asString) asHelpTopic]. topic addSubtopic: page. ]. ((aDescription subclasses asSet) removeAllFoundIn: pageClasses; yourself) do: [:subclass | topic subtopics add: subclass asHelpTopic ]. ^topic! ----- Method: HelpBuilder class>>buildHelpTopicFrom: (in category 'building') ----- buildHelpTopicFrom: aHelpTopicDescription "Start building from the given help topic description" ^(self new) rootToBuildFrom: aHelpTopicDescription; build; topicToBuild ! ----- Method: HelpBuilder>>build (in category 'building') ----- build self subclassResponsibility ! ----- Method: HelpBuilder>>initialize (in category 'initialize-release') ----- initialize "Initializes the receiver" super initialize. topicToBuild := self topicClass new. ! ----- Method: HelpBuilder>>rootToBuildFrom: (in category 'accessing') ----- rootToBuildFrom: anObject rootToBuildFrom := anObject! ----- Method: HelpBuilder>>topicClass (in category 'private accessing') ----- topicClass ^HelpTopic! ----- Method: HelpBuilder>>topicToBuild (in category 'accessing') ----- topicToBuild ^topicToBuild! HelpBuilder subclass: #PackageAPIHelpBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! ----- Method: PackageAPIHelpBuilder>>build (in category 'building') ----- build |pTopic| topicToBuild := (HelpTopic named: rootToBuildFrom bookName). rootToBuildFrom packages do: [:package| pTopic := HelpTopic named: package. topicToBuild addSubtopic: pTopic. self buildPackageTopic: pTopic. ] ! ----- Method: PackageAPIHelpBuilder>>buildPackageTopic: (in category 'building') ----- buildPackageTopic: pTopic | classTopic classes | classes := (PackageInfo named: pTopic title) classes asSortedCollection: [:cl1 :cl2 | cl1 name < cl2 name]. classes do: [:aClass| classTopic := ClassAPIHelpBuilder buildHierarchicalHelpTopicFrom: aClass withSubclasses: false withMethods: true. pTopic addSubtopic: classTopic ] ! Object subclass: #HelpIcons instanceVariableNames: '' classVariableNames: 'Icons' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpIcons commentStamp: 'tbn 3/8/2010 09:29' prior: 0! This class is used to store help icons for the help browser. Typically one implements a method returning a 12x12 Form instance which should not be called directly. Since the class provides an internal icon cache (so the icons can be reused without creating too many new instances) the icons should be accessed using the #iconNamed: message with the method selector as argument. To create a form from an icon file stored on disk you can use the following code: | image stream | image := ColorForm fromFileNamed: '/path/to/icon.png'. stream := WriteStream with: String new. image storeOn: stream. stream contents inspect.! ----- Method: HelpIcons class>>blankIcon (in category 'private icons') ----- blankIcon ^Form extent: 12 @ 1 depth:8! ----- Method: HelpIcons class>>bookIcon (in category 'private icons') ----- bookIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 284817913 552924404 0 0 0 0 0 0 0 0 0 817149108 3747766882 4287730065 2679749049 549766340 0 0 0 0 0 0 1086110908 4016202338 4287137928 4288914339 4288914339 4289111718 3216290996 1086505666 0 0 0 816754350 4014952271 4287137928 4289309097 4289769648 4289111718 4288453788 4288453788 4288453788 2947658161 0 814846353 4283782485 4287072135 4288059030 4288059030 4288387995 4289243304 4289309097 4287927444 4287598479 2411050421 1081900156 4283585106 4286611584 4287532686 4287532686 4287466893 4287466893 4287401100 4287401100 4287401100 4288716960 2946868645 3211290728 4288651167 4287269514 4287006342 4287006342 4287006342 4286940549 4286940549 4287203721 4289177511 3483213213 281725642 2677183122 4293190884 4292861919 4289177511 4286874756 4286611584 4286611584 4287006342 4289638062 4020084125 549042617 0 282054607 2677643673 4289572269 4293256677 4292796126 4288980132 4287137928 4290164406 4020215711 816754350 0 0 0 0 551082200 2677643673 4289572269 4293256677 4292401368 4289177511 1085584564 0 0 0 0 0 0 0 551213786 2677643673 4288651167 1623244992 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ----- Method: HelpIcons class>>iconNamed: (in category 'accessing') ----- iconNamed: aSymbol ^self icons at: aSymbol ifAbsentPut: [self perform: aSymbol]! ----- Method: HelpIcons class>>icons (in category 'accessing') ----- icons Icons isNil ifTrue: [Icons := Dictionary new]. ^Icons! ----- Method: HelpIcons class>>packageIcon (in category 'private icons') ----- packageIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 1075649821 3744937783 3208395836 807016986 0 0 0 0 0 0 537857807 2939368243 4283256141 4284045657 4284572001 4284111450 2671524924 269488144 0 0 0 2150575919 4014820685 4284111450 4284374622 4284769380 4285098345 4285295724 4286216826 4017057647 1883456323 0 1076505130 4283848278 4284769380 4284966759 4285624689 4285690482 4285887861 4286611584 4287269514 4287861651 4287269514 1074597133 1076965681 4283914071 4283848278 4285953654 4286216826 4286414205 4286940549 4287466893 4287335307 4286808963 4286743170 1074399754 1077163060 4284637794 4284045657 4284835173 4285887861 4287269514 4287335307 4286282619 4286216826 4286874756 4287006342 1074465547 1077294646 4284835173 4284703587 4285361517 4285624689 4286414205 4285624689 4286085240 4286677377 4287269514 4287401100 1074465547 1077426232 4285098345 4285032552 4286019447 4285822068 4286743170 4286348412 4286677377 4287203721 4287730065 4287795858 1074531340 1077492025 4285229931 4285427310 4286808963 4286216826 4287137928 4287072135 4287401100 4287795858 4288256409 4288190616 1074531340 269356558 2672051268 4285493103 4287598479 4286940549 4287532686 4287795858 4287993237 4288387995 4287006342 2404668500 268501249 0 0 1075912993 3479726184 4287598479 4287927444 4288453788 4287993237 2943118444 539371046 0 0 0 0 0 0 1615086660 4017781370 3749148535 1078347334 0 0 0 0) offset: 0@0)! ----- Method: HelpIcons class>>pageIcon (in category 'private icons') ----- pageIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 221196079 1366981242 1366915449 1366915449 1366849656 1366783863 1128876361 33554432 0 0 0 0 726552142 4294309365 4294243572 4294111986 4294046193 4293914607 4292861919 2843705215 319885585 0 0 0 726551886 4294177779 4294111986 4293980400 4293914607 4293848814 4293717228 4292138196 3734147730 269619730 0 0 726486349 4294046193 4293980400 4293914607 4293783021 4293717228 4293585642 4293454056 4291085508 639705377 0 0 726420557 4293980400 4293848814 4293783021 4293651435 4293585642 4293519849 4293388263 4292993505 640034342 0 0 726420556 4293848814 4293717228 4293651435 4293585642 4293454056 4293388263 4293256677 4293190884 623322919 0 0 726354764 4293717228 4293651435 4293519849 4293454056 4293322470 4293256677 4293125091 4293059298 623257126 0 0 726354507 4293585642 4293519849 4293388263 4293322470 4293190884 4293125091 4293059298 4292993505 623191333 0 0 726288970 4293454056 4293388263 4293256677 4293190884 4293125091 4292993505 4292993505 4292993505 623191333 0 0 726223178 4293322470 4293256677 4293190884 4293059298 4292993505 4292993505 4292993505 4292993505 623191333 0 0 726223177 4293256677 4293125091 4293059298 4292993505 4292993505 4292993505 4292993505 4292993505 623191333 0 0 490092087 3080033685 3079967892 3079967892 3079967892 3079967892 3079967892 3079967892 3079967892 454629657 0) offset: 0@0)! ----- Method: HelpIcons class>>refreshIcon (in category 'private icons') ----- refreshIcon ^(Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 895969127 526080859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1884706390 4168710521 2288675434 271330348 0 0 0 0 0 0 0 0 0 828465505 2609087363 3615917702 4269439610 4285887861 4285624689 3899156584 1766607948 67569415 0 0 0 0 0 50529027 2306242166 4237069452 4286940549 4286611584 4286282619 4285887861 4285558896 4285229931 4268189543 2235514687 0 0 0 0 0 2590862701 4287598479 4287269514 4270097540 3329652342 3312217196 4285887861 4285558896 3345179491 1011567435 0 0 0 0 0 1263423054 4287532686 4287532686 3867378563 1096835168 0 1885166941 3681579120 1549227863 50923785 0 0 0 0 0 0 3061545851 4287795858 4236937866 811951461 0 0 641547581 137441585 0 0 0 0 0 0 0 34936085 4102720138 4287795858 3011016824 0 0 0 0 0 0 0 0 0 0 0 0 272317243 4287861651 4287795858 2489607268 0 0 0 0 0 0 0 0 68095759 0 0 0 204682035 4287730065 4287795858 2658432116 0 0 0 0 0 0 0 34014983 3965146967 4283979864 3125694030 0 0 3767044232 4287795858 3884287365 137244206 0 0 0 0 0 0 1129863256 4284769380 4284506208 2739423304 0 0 2189459584 4287795858 4287532686 2541123190 16843009 0 0 0 0 305805882 3597166696 4284703587 4250885983 910114623 0 0 273698896 3834218889 4287532686 4287335307 3094442353 1094532413 101255433 286199567 1582124365 3731318631 4284966759 4284703587 2689946965 0 0 0 0 879126118 3985082247 4287269514 4286940549 4286611584 4285624689 4285558896 4285624689 4285229931 4284966759 3227212635 220998700 0 0 0 0 0 509698401 2977659771 4286743170 4286545791 4286282619 4285887861 4285558896 4100417383 2170116441 103295016 0 0 0 0 0 0 0 0 575820370 1734895720 2121298032 2037017194 1448564567 255013683 0 0 0 0 0) offset: 0@0)! Object subclass: #SystemReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Utilities'! !SystemReference commentStamp: 'tbn 4/30/2010 15:35' prior: 0! This class defines the full reference help for the system. (contents for the full API Help). Just run "HelpBrowser openOn: SystemReference". ! ----- Method: SystemReference class>>all (in category 'help topic creation') ----- all "HelpBrowser openOn: self all " ^(ClassAPIHelpTopic new) theClass: ProtoObject; withSubclasses: true; withMethods: true; subclassesAsSeparateTopic: false! ----- Method: SystemReference class>>asHelpTopic (in category 'help topic creation') ----- asHelpTopic "HelpBrowser openOn: SystemReference" ^self hierarchyFor: ProtoObject ! ----- Method: SystemReference class>>forClass: (in category 'help topic creation') ----- forClass: aClass |root topic | root := HelpTopic named: 'System reference for ', aClass name. topic := ClassAPIHelpTopic new theClass: aClass; withSubclasses: true; withMethods: true; subclassesAsSeparateTopic: false. root addSubtopic: topic. ^root! ----- Method: SystemReference class>>hierarchyFor: (in category 'help topic creation') ----- hierarchyFor: aClass | root topic | root := HelpTopic named: 'System reference for ', aClass name. topic := (ClassAPIHelpTopic new) theClass: aClass; withSubclasses: true; withMethods: false; subclassesAsSeparateTopic: false. root addSubtopic: topic. ^ root! ----- Method: SystemReference class>>hierarchyWithMethodsFor: (in category 'help topic creation') ----- hierarchyWithMethodsFor: aClass | root topic | root := HelpTopic named: 'System reference for ', aClass name. topic := (ClassAPIHelpTopic new) theClass: aClass; withSubclasses: true; withMethods: true; subclassesAsSeparateTopic: true. root addSubtopic: topic. ^ root! ----- Method: Class>>asHelpTopic (in category '*HelpSystem-Core') ----- asHelpTopic ^SystemReference forClass: self!

1 0

← Newer
1
...
9
10
11
12
13
14
15
16
17
Older →

Jump to page: