Squeak-dev January 2022

squeak-dev@lists.squeakfoundation.org

33 participants
361 discussions

The Trunk: Morphic-ct.1841.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-ct.1841.mcz ==================== Summary ==================== Name: Morphic-ct.1841 Author: ct Time: 3 January 2022, 10:12:56.140397 pm UUID: 13c07ce7-f89f-7b48-b5e8-baa520ea1951 Ancestors: Morphic-ct.1840 Improves multilingual support at various places. =============== Diff against Morphic-ct.1840 =============== Item was changed: ----- Method: FontImporterTool>>buildButtonBarWith: (in category 'toolbuilder') ----- buildButtonBarWith: builder "Build the button bar" | panelSpec buttonSpec | panelSpec := builder pluggablePanelSpec new. panelSpec layout: #horizontal; children: OrderedCollection new. buttonSpec := builder pluggableButtonSpec new model: self; label: 'Import' translated; + help: 'Include the font data in the image and provide a TextStyle for the font' translated; - help: 'Include the font data in the image and provide a TextStyle for the font'; action: #import; yourself. panelSpec children addLast: buttonSpec. buttonSpec := builder pluggableButtonSpec new model: self; label: 'Close' translated; action: #close; yourself. panelSpec children addLast: buttonSpec. ^panelSpec! Item was changed: ----- Method: FontImporterTool>>import (in category 'actions') ----- import | megaSize filenames fonts | fonts := self currentSelection. filenames := fonts allFilenames. megaSize := ((filenames inject: 0 into: [ :sum :fn | sum + (FileStream readOnlyFileNamed: fn do: [:file | file size])]) / (1024 * 1024)) asFloat. (UIManager default confirm: ( 'About to import {1}{2}.\\This is at least {3} MB of space required in the image.\ Please respect the copyright and embedding restrictions of the font.\ Proceed?' + withCRs translated format: { - withCRs format: { self currentParent ifNotNil: [:p| p fontname, ' ', self currentSelection fontname] ifNil: [self currentSelection fontname]. + filenames size > 1 ifTrue: [' ({1} font files)' translated format: {filenames size}] ifFalse: ['']. - filenames size > 1 ifTrue: [' (', filenames size, ' font files)'] ifFalse: ['']. megaSize printShowingDecimalPlaces: 2})) ifTrue: [ filenames do: [:filename | | readFonts | readFonts := TTCFontDescription addFromTTFile: filename. readFonts isCollection ifFalse: [TTCFont newTextStyleFromTT: readFonts] ifTrue: [self importFontFamily: readFonts]]]. self allFonts: nil. "force redraw" TTCFont registerAll.! Item was changed: ----- Method: FontImporterTool>>link (in category 'actions') ----- link | filenames fonts | fonts := self currentSelection. self warningSeen ifFalse: [ + (Project uiManager confirm: ( - (UIManager default confirm: ( 'Note that linking a font instead of importing may make the image un-portable, since the linked font must be present on the system the next time the image is run. + This warning is only shown once per session.' translated) trueChoice: 'Proceed' translated falseChoice: 'Cancel' translated) - This warning is only shown once per session.' ) trueChoice: 'Proceed' falseChoice: 'Cancel') ifFalse: [^ self]. self warningSeen: true].. filenames := fonts allFilenames. filenames do: [:filename | | readFonts | readFonts := TTFileDescription readFontsFrom: filename. readFonts isCollection ifFalse: [TTCFont newTextStyleFromTT: readFonts] ifTrue: [self importFontFamily: readFonts]]. self allFonts: nil. "force redraw" TTCFont registerAll.! Item was changed: ----- Method: KeyboardExerciser>>drawOn: (in category 'drawing') ----- drawOn: aCanvas super drawOn: aCanvas. aCanvas + drawString: 'Move your mouse cursor to here and start typing. Try modifiers, too.' translated - drawString: 'Move your mouse cursor to here and start typing. Try modifiers, too.' at: self topLeft font: Preferences standardButtonFont color: Color gray.! Item was changed: ----- Method: KeyboardExerciser>>logEvent: (in category 'event handling') ----- logEvent: evt | eventMorph | evt = self lastEvent ifTrue: [^ self logEventRepetition: evt]. eventMorph := evt asMorph. eventMorph setProperty: #event toValue: evt copy; + balloonText: ('Click to inspect. Shift+click to explore.\\Virtual key: {8}\Virtual modifiers: {5}\\Physical key: {9}\Physical modifiers: {6}\\Key value: 0x{1} ({2}) \Key character: {3}\Key string: {4}\\{7}' withCRs translated format: { - balloonText: ('Click to inspect. Shift+click to explore.\\Virtual key: {8}\Virtual modifiers: {5}\\Physical key: {9}\Physical modifiers: {6}\\Key value: 0x{1} ({2}) \Key character: {3}\Key string: {4}\\{7}' withCRs format: { evt keyValue printPaddedWith: $0 to: 2 base: 16. evt keyValue. evt isKeystroke ifTrue: [evt keyCharacter printString] ifFalse: ['-']. evt isKeystroke ifTrue: [evt keyString printString] ifFalse: ['-']. (evt virtualModifiers joinSeparatedBy: ' ') asUppercase. (evt physicalModifiers joinSeparatedBy: ' ') asUppercase. evt printString. evt virtualKey printString. evt physicalKey asString printString}). eventMorph on: #mouseEnter send: #handleEvent:emphasize: to: self; on: #mouseLeave send: #handleEvent:deemphasize: to: self; on: #mouseDown send: #handleEvent:inspect: to: self. self addMorphBack: eventMorph.! Item was changed: ----- Method: KeyboardExerciser>>logEventRepetition: (in category 'event handling') ----- logEventRepetition: evt | label lastEvents box | (self submorphs last hasProperty: #repetition) ifTrue: [box := self submorphs last. label := box submorphs first] ifFalse: [ box := Morph new setProperty: #repetition toValue: true; color: Color transparent; layoutPolicy: TableLayout new; hResizing: #shrinkWrap; vResizing:#shrinkWrap; yourself. label := '' asText asMorph lock. box addMorph: label. box setProperty: #event toValue: (OrderedCollection with: self lastEvent). self addMorphBack: box]. lastEvents := box valueOfProperty: #event. lastEvents add: evt copy. box setProperty: #event toValue: lastEvents. label newContents: (('x ', (lastEvents size)) asText addAttribute: (TextFontReference toFont: Preferences standardButtonFont); yourself). box balloonText: ('{1}{2}' format: { + lastEvents size > 10 ifTrue: ['... {1} older events and:\' withCRs translated format: {lastEvents size - 10}] ifFalse: ['']. - lastEvents size > 10 ifTrue: ['... ', (lastEvents size - 10), ' older events and:', String cr] ifFalse: ['']. (lastEvents last: (10 min: lastEvents size)) joinSeparatedBy: String cr. }). box on: #mouseEnter send: #handleEvent:emphasize: to: self; on: #mouseLeave send: #handleEvent:deemphasize: to: self; on: #mouseDown send: #handleEvent:inspect: to: self.! Item was changed: ----- Method: MenuItemMorph>>debugAction (in category 'browse') ----- debugAction (Process forBlock: [self doButtonAction] runUntil: [:context | context selector = self effectiveActionSelector]) + debugWithTitle: ('Debug menu action "{1}" in model "{2}"' translated format: {self contents. self target printString}).! - debugWithTitle: ('Debug menu action "{1}" in model "{2}"' format: {self contents. self target printString}).! Item was changed: ----- Method: MenuMorph>>addItem (in category 'menu') ----- addItem | string sel | + string := Project uiManager request: 'Label for new item?' translated. - string := UIManager default request: 'Label for new item?'. string isEmpty ifTrue: [^ self]. + sel := Project uiManager request: 'Selector?' translated. - sel := UIManager default request: 'Selector?'. sel isEmpty ifFalse: [sel := sel asSymbol]. self add: string action: sel. ! Item was changed: ----- Method: MenuMorph>>addTitle (in category 'menu') ----- addTitle | string | + string := Project uiManager request: 'Title for this menu?' translated. - string := UIManager default request: 'Title for this menu?'. string isEmpty ifTrue: [^ self]. self addTitle: string. ! Item was changed: ----- Method: MenuMorph>>detachSubMenu: (in category 'menu') ----- detachSubMenu: evt | possibleTargets item subMenu index | possibleTargets := self items select:[:any| any hasSubMenu]. possibleTargets size > 0 ifTrue:[ + index := Project uiManager - index := UIManager default chooseFrom: (possibleTargets collect:[:t| t contents asString]) + title: 'Which menu?' translated. - title: 'Which menu?'. index = 0 ifTrue:[^self]]. item := possibleTargets at: index. subMenu := item subMenu. subMenu ifNotNil: [ item subMenu: nil. item delete. subMenu stayUp: true. subMenu popUpOwner: nil. subMenu addTitle: item contents. evt hand attachMorph: subMenu]. ! Item was changed: ----- Method: MenuMorph>>showKeyboardHelp (in category 'keystroke helpers') ----- showKeyboardHelp | help | help := self balloonMorphClass + string: 'Enter text to narrow selection\down to matching items ' translated - string: 'Enter text to narrow selection\down to matching items ' withCRs for: self corner: #topLeft. help popUpAt: self topCenter forHand: self activeHand! Item was changed: ----- Method: MenuMorph>>toggleStayUp: (in category 'menu') ----- toggleStayUp: evt "Toggle my 'stayUp' flag and adjust the menu item to reflect its new state." self items do: [:item | item isStayUpItem ifTrue: [self stayUp: stayUp not. stayUp + ifTrue: [item contents: 'dismiss this menu' translated] + ifFalse: [item contents: 'keep this menu up' translated]]]. - ifTrue: [item contents: 'dismiss this menu'] - ifFalse: [item contents: 'keep this menu up']]]. evt hand releaseMouseFocus: self. + stayUp ifFalse: [self topRendererOrSelf delete].! - stayUp ifFalse: [self topRendererOrSelf delete]. - ! Item was changed: ----- Method: MorphicProject>>loadFromServer: (in category 'file in/out') ----- loadFromServer: newerAutomatically "If a newer version of me is on the server, load it." | pair resp server | self assureIntegerVersion. self isCurrentProject ifTrue: ["exit, then do the command" ^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated ]. server := self tryToFindAServerWithMe ifNil: [^ nil]. pair := self class mostRecent: self name onServer: server. pair first ifNil: [^ self inform: ('can''t find file on server for {1}' translated format: {self name})]. self currentVersionNumber > pair second ifTrue: [ ^ self inform: ('That server has an older version of the project.' translated)]. version = (Project parseProjectFileName: pair first) second ifTrue: [ resp := (UIManager default chooseFrom: (Array with: 'Reload anyway' translated with: 'Cancel' translated withCRs) title: 'The only changes are the ones you made here.' translated). resp ~= 1 ifTrue: [^ nil] ] ifFalse: [ newerAutomatically ifFalse: [ resp := (UIManager default + chooseFrom: {'Load it' translated. 'Cancel' translated} + title: 'A newer version exists on the server.' translated). - chooseFrom: #('Load it' 'Cancel') - title: 'A newer version exists on the server.'). resp ~= 1 ifTrue: [^ nil] ]. ]. "let's avoid renaming the loaded change set since it will be replacing ours" self projectParameters at: #loadingNewerVersion put: true. ComplexProgressIndicator new targetMorph: nil; historyCategory: 'project loading'; withProgressDo: [ ProjectLoading installRemoteNamed: pair first from: server named: self name in: parentProject + ]! - ] - ! Item was changed: ----- Method: ObjectExplorerWrapper>>asString (in category 'converting') ----- asString | explorerString label separator | explorerString := [self objectString] on: Error + do: ['<error: {1} in {2}: evaluate "{3}" to debug>' translated format: {self object class name. #asExplorerString. self itemName , ' asExplorerString'}]. - do: ['<error: ', self object class name, ' in asExplorerString: evaluate "' , self itemName , ' asExplorerString" to debug>']. (explorerString includes: Character cr) ifTrue: [explorerString := explorerString withSeparatorsCompacted]. label := self itemName ifNil: ['']. (label includes: Character cr) ifTrue: [label := label withSeparatorsCompacted]. separator := self class showContentsInColumns ifTrue: [String tab] ifFalse: [label ifEmpty: [''] ifNotEmpty: [': ']]. ^ '{1}{2}{3}' format: {label. separator. explorerString}! Item was changed: ----- Method: PasteUpMorph>>saveOnFile (in category 'objects from disk') ----- saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | aFileName fileStream | self flag: #bob0302. self isWorldMorph ifTrue: [^self project saveAs]. + aFileName := ('my {1}' translated format: {self class name}) , '.project' asFileName. "do better?" - aFileName := ('my {1}.project' translated format: {self class name}) asFileName. "do better?" aFileName := UIManager default saveFilenameRequest: 'File name?' translated initialAnswer: aFileName. aFileName ifNil: [^ Beeper beep]. self allMorphsDo: [:m | m prepareToBeSaved]. fileStream := FileStream newFileNamed: aFileName. fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! Item was changed: ----- Method: PluggableButtonMorph>>debugAction (in category 'debug menu') ----- debugAction self updateArguments. (Process forBlock: [self doButtonAction] runUntil: [:context | context selector = self effectiveActionSelector]) + debugWithTitle: ('Debug button action "{1}" in model "{2}"' translated format: {self label. self target printString}).! - debugWithTitle: ('Debug button action "{1}" in model "{2}"' format: {self label. self target printString}).! Item was changed: ----- Method: PluggableListMorph>>debugGetList (in category 'debug and other') ----- debugGetList (Process forBlock: [model perform: getListSelector] runUntil: [:context | context selector = getListSelector]) + debugWithTitle: ('Debug get-list invocation in model "{1}"' translated format: {model printString}).! - debugWithTitle: ('Debug get-list invocation in model "{1}"' format: {model printString}).! Item was changed: ----- Method: PolygonMorph>>smoothOrSegmentedPhrase (in category 'access') ----- smoothOrSegmentedPhrase - | lineName | - lineName := (closed - ifTrue: ['outline'] - ifFalse: ['line']) translated. + | lineName | + lineName := closed + ifTrue: ['outline' translated] + ifFalse: ['line' translated]. + + ^ self isCurve + ifTrue: ['make segmented {1}' translated format: {lineName}] + ifFalse: ['make smooth {1}' translated format: {lineName}]! - ^ self isCurve - ifTrue: ['make segmented {1}' translated format: {lineName}] - ifFalse: ['make smooth {1}' translated format: {lineName}].! Item was changed: ----- Method: SmalltalkEditor>>tallySelection (in category 'do-its') ----- tallySelection "Treat the current selection as an expression; evaluate it and return the time took for this evaluation" | code result rcvr ctxt v | self lineSelectAndEmptyCheck: [^ self]. (model respondsTo: #doItReceiver) ifTrue: [ rcvr := model doItReceiver. ctxt := model doItContext] ifFalse: [rcvr := ctxt := nil]. result := [ | cm | code := self selectionAsStream. cm := rcvr class evaluatorClass new compiledMethodFor: code in: ctxt to: rcvr notifying: self ifFail: [morph flash. ^ self]. Time millisecondsToRun: [v := cm valueWithReceiver: rcvr arguments: (ctxt ifNil: [#()] ifNotNil: [{ctxt}]) ]. ] on: OutOfScopeNotification do: [ :ex | ex resume: true]. UIManager default + inform: ('Expression{1} {2} Time (compile and execute) {3} ms Result {4}' translated format: { - inform: ('Expression{1} {2} Time (compile and execute) {3} ms Result {4}' format: { rcvr ifNil: [''] ifNotNil: [' (', (rcvr printString truncateWithElipsisTo: 20), ')']. (code contents truncateWithElipsisTo: 200) copyReplaceAll: String cr with: ' '. result printString. v printString truncateWithElipsisTo: 100}) asTextFromHtml.! Item was changed: ----- Method: TextAnchor class>>alignmentExamples (in category 'examples') ----- alignmentExamples "self alignmentExamples" | anchoredMorph textMorph text demoMorph | demoMorph := Morph new changeTableLayout; color: Color white; hResizing: #shrinkWrap; vResizing: #shrinkWrap; yourself. #(top center bottom) do: [:morphAlignment | #(top center baseline bottom) do: [:textAlignment | anchoredMorph := Morph new. anchoredMorph textAnchorProperties verticalAlignment: {morphAlignment . textAlignment}. anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding top: 10). text := Text streamContents: [ :stream | stream + nextPutAll: ('Here is an {1}, {2} example: ' translated format: {morphAlignment . textAlignment}); - nextPutAll: ('Here is an {1}, {2} example: ' format: {morphAlignment . textAlignment}); nextPutAll: (Text string: Character startOfHeader asString attributes: {TextAnchor new anchoredMorph: anchoredMorph. TextColor color: Color transparent}); + nextPutAll: ' with the morph in the text.' translated]. - nextPutAll: ' with the morph in the text.']. textMorph := text asMorph. textMorph height: 100. demoMorph addMorph: textMorph]]. demoMorph openInWorld! Item was changed: ----- Method: TextEditor>>findReplace (in category 'menu messages') ----- findReplace self setSearchFromSelectionOrHistory; setReplacementFromHistory. (Project uiManager + request: 'Find what to replace?' translated - request: 'Find what to replace?' initialAnswer: FindText) ifNotEmpty: [:find | (Project uiManager + request: ('Replace ''{1}'' with?' translated format: {find}) - request: ('Replace ''{1}'' with?' format: {find}) initialAnswer: (ChangeText ifEmpty: [find]) onCancelReturn: nil) ifNotNil: [:replace | FindText := find. ChangeText := replace. self findReplaceAgainNow]]! Item was changed: ----- Method: TheWorldMainDockingBar>>scaleFactorsOn: (in category 'submenu - extras') ----- scaleFactorsOn: menu | presets currentScaleFactor currentPlatformScaleFactor | currentScaleFactor := (Display relativeUiScaleFactor * 100) rounded. currentPlatformScaleFactor := Display platformScaleFactorKnown ifTrue: [(Display platformScaleFactor * 100) rounded]. presets := 100 to: 300 by: 25. presets do: [:scale | scale = 175 ifTrue: [menu addLine]. "TTCFont used after this line..." menu addItem: [:item| item contents: ('{1}{2}%{3}' format: { currentScaleFactor = scale ifTrue: ['<yes>'] ifFalse: ['<no>']. scale. DisplayScreen relativeScaleFactorEnabled ifTrue: ['' "macOS"] ifFalse: [ scale = currentPlatformScaleFactor + ifTrue: [' (recommended)' translated] ifFalse: ['']] - ifTrue: [' (recommended)'] ifFalse: ['']] }); target: Display; selector: #relativeUiScaleFactor:; arguments: {scale / 100}]]. menu addLine. menu addItem: [:item | item + contents: ((presets includes: currentScaleFactor) not ifTrue: ['<yes>' , 'Custom: ' translated, currentScaleFactor, '% ...'] ifFalse: ['<no>' , 'Other scale factor...' translated]); - contents: ((presets includes: currentScaleFactor) not ifTrue: ['<yes> Custom: ', currentScaleFactor, '% ...'] ifFalse: ['<no>Other scale factor...']); target: self; selector: #chooseCustomScaleFactor].!

1 0

Re: [squeak-dev] ExtendedClipboardInterface and ClipboardExtendedPlugin state?
by Bernhard Pieber 03 Jan '22

03 Jan '22

Hi, Maybe this question is better asked on the vm-dev list. Does anyone know the status of the ClipboardExtendedPlugin? Happy New Year! Bernhard > Am 20.12.2021 um 09:38 schrieb Bernhard Pieber <bernhard(a)pieber.com>: > > Hi everyone, > > I tried to copy a form as PNG to the clipboard like this: > ExtendedClipboardInterface current addClipboardDataConvertFormToPNG: self imageForm > > This seems not to work correctly. If I paste it to TextEdit I get the binary data starting with PNG instead of the image itself. It looks as if the ClipboardExtendedPlugin is not loaded. The plugin seems to be in the current VM source (src/pugins/ClipboardExtendedPlugin), though. I am on macOS Big Sur 11.6.1. > > Should this work? I tried on Squeak 3.4, 4.6 and 5.3 but the ExtendedClipboardInterface is not loaded in these images. > > Cheers, > Bernhard

3 3

The Trunk: MonticelloConfigurations-ct.171.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of MonticelloConfigurations to project The Trunk: http://source.squeak.org/trunk/MonticelloConfigurations-ct.171.mcz ==================== Summary ==================== Name: MonticelloConfigurations-ct.171 Author: ct Time: 3 January 2022, 10:00:53.373397 pm UUID: 40c81102-910c-0348-ba1a-26ee8781b2dc Ancestors: MonticelloConfigurations-mt.170 Improves multilingual support. =============== Diff against MonticelloConfigurations-mt.170 =============== Item was changed: ----- Method: MCConfiguration>>depsSatisfying:versionDo:displayingProgress: (in category 'private') ----- depsSatisfying: selectBlock versionDo: verBlock displayingProgress: progressString | count selectedVersions cleanWorkingCopies | self cacheAllFileNamesDuring: [ self repositories do: [ :eachRepository | MCRepositoryGroup default addRepository: eachRepository ]. "First, download selected versions" count := 0. selectedVersions := OrderedCollection new. self withProgress: progressString in: self dependencies do: [ :dep | | verName repo | verName := dep versionInfo name. self class extraProgressInfo ifTrue: + [ ProgressNotification signal: '' extra: ('Downloading {1}' translated format: {verName}) ]. - [ ProgressNotification signal: '' extra: 'Downloading ' , verName ]. repo := self repositories detect: [ :eachRepository | eachRepository includesVersionNamed: verName ] + ifNone: [ self logError: ('Version {1} not found in any repository' translated format: {verName}). + self logError: 'Aborting' translated. - ifNone: [ self logError: 'Version ' , verName , ' not found in any repository'. - self logError: 'Aborting'. ^ count ]. (selectBlock value: dep) ifTrue: [ | version | version := self versionNamed: verName for: dep from: repo. + version ifNil: [ self logError: ('Could not download version {1} from {2}' translated format: {verName. repo description}). + self logError: 'Aborting' translated. - version ifNil: [ self logError: 'Could not download version ' , verName , ' from ' , repo description. - self logError: 'Aborting'. ^ count ]. dep package workingCopy newRepositoryGroupIfDefault. "fix old working copies" dep package workingCopy repositoryGroup addRepository: repo. selectedVersions add: version]]. "Then, process only those definitions that moved from one package to another, to avoid order dependence" cleanWorkingCopies := MCWorkingCopy allManagers select: [ :wc | wc modified not and: [ selectedVersions anySatisfy: [ :v | wc package = v package ] ] ]. MCReorganizationPreloader preloadMovesBetween: selectedVersions. "Finally, load/merge selected versions" self withProgress: progressString in: selectedVersions do: [ :version | self logUpdate: version package with: version. self class extraProgressInfo ifTrue: + [ ProgressNotification signal: '' extra: ('Installing {1}' translated format: {version info name}) ]. - [ ProgressNotification signal: '' extra: 'Installing ' , version info name ]. verBlock value: version. count := count + 1 ]. "Clean up packages made dirty by MCReorganizationPreloader" cleanWorkingCopies select: [ :wc | wc modified ] thenDo: [ :wc | wc checkModified ]. ]. ^ count! Item was changed: ----- Method: MCConfiguration>>load (in category 'actions') ----- load ^self depsSatisfying: [:dep | dep isCurrent not] versionDo: [:ver | ver load] + displayingProgress: 'loading packages' translated! - displayingProgress: 'loading packages' - ! Item was changed: ----- Method: MCConfiguration>>merge (in category 'actions') ----- merge ^self depsSatisfying: [:dep | dep isFulfilledByAncestors not] versionDo: [:ver | ver merge] + displayingProgress: 'merging packages' translated! - displayingProgress: 'merging packages' - ! Item was changed: ----- Method: MCConfiguration>>updateFromRepositoriesWithoutCaching (in category 'updating') ----- updateFromRepositoriesWithoutCaching | oldNames newNames sortedNames newDeps | oldNames := self dependencies collect: [:dep | dep versionInfo versionName]. newNames := Dictionary new. self repositories do: [:repo | + ProgressNotification signal: '' extra: ('Checking {1}' translated format: {repo description}). - ProgressNotification signal: '' extra: 'Checking ', repo description. (repo possiblyNewerVersionsOfAnyOf: oldNames) do: [:newName | newNames at: newName put: repo]] + displayingProgress: 'Searching new versions' translated. - displayingProgress: 'Searching new versions'. sortedNames := newNames keys asArray sort: [:a :b | a versionNumber > b versionNumber]. newDeps := OrderedCollection new: self dependencies size. self dependencies do: [:dep | newDeps add: (sortedNames detect: [:each | each packageAndBranchName = dep packageAndBranchName] ifFound: [ :newName | | repo | repo := newNames at: newName. (self versionInfoNamed: newName for: dep from: repo) ifNil: [ dep ] ifNotNil: [ :info | MCVersionDependency package: dep package info: info ] ] ifNone: [ dep ]) ] displayingProgress: 'Downloading new versions ...' translated. + self dependencies: newDeps.! - self dependencies: newDeps. - ! Item was changed: ----- Method: MCConfiguration>>updateFromRepositoriesWithoutCaching: (in category 'updating') ----- updateFromRepositoriesWithoutCaching: packageIndex | oldNames newNames sortedNames newDeps dep | dep := dependencies at: packageIndex. oldNames := {dep versionInfo versionName}. newNames := Dictionary new. self repositories do: [:repo | + ProgressNotification signal: '' extra: ('Checking {1}' translated format: {repo description}). - ProgressNotification signal: '' extra: 'Checking ', repo description. (repo possiblyNewerVersionsOfAnyOf: oldNames) do: [:newName | newNames at: newName put: repo]] + displayingProgress: 'Searching new versions' translated. - displayingProgress: 'Searching new versions'. sortedNames := newNames keys asArray sort: [:a :b | a versionNumber > b versionNumber]. newDeps := self dependencies copy. newDeps at: packageIndex put: ( sortedNames detect: [:each | each packageAndBranchName = dep packageAndBranchName] ifFound: [ :newName | | repo | repo := newNames at: newName. (self versionInfoNamed: newName for: dep from: repo) ifNil: [ dep ] ifNotNil: [ :info | MCVersionDependency package: dep package info: info ] ] ifNone: [ dep ]). + self dependencies: newDeps.! - self dependencies: newDeps. - ! Item was changed: ----- Method: MCConfiguration>>upgrade (in category 'actions') ----- upgrade ^self depsSatisfying: [:dep | dep isFulfilledByAncestors not] versionDo: [:ver | (self class upgradeIsMerge and: [ver shouldMerge]) ifFalse: [ver load] ifTrue: [[ver merge] on: MCNoChangesException do: [:req| req resume ] on: MCMergeResolutionRequest do: [:request | request merger conflicts isEmpty ifTrue: [request resume: true] ifFalse: [request pass]] on: Deprecation do: [:req| req resume ]]] + displayingProgress: 'upgrading packages' translated! - displayingProgress: 'upgrading packages'! Item was changed: ----- Method: MCConfiguration>>versionNamed:for:from: (in category 'private') ----- versionNamed: aMCVersionName for: aDependency from: repo | baseName fileName ver | (repo filterFileNames: repo cachedFileNames forVersionNamed: aMCVersionName) ifNotEmptyDo: [:cachedNames | fileName := cachedNames anyOne. self class extraProgressInfo + ifTrue: [ProgressNotification signal: '' extra: ('Using cached {1}' translated format: {fileName})]. - ifTrue:[ProgressNotification signal: '' extra: 'Using cached ', fileName]. ver := repo versionNamed: fileName]. ver ifNil: [ baseName := self diffBaseFor: aDependency. (baseName notNil and: [baseName ~= aMCVersionName and: [repo includesVersionNamed: baseName]]) ifTrue: [ fileName := (MCDiffyVersion nameForVer: aMCVersionName base: baseName), '.mcd'. self class extraProgressInfo + ifTrue: [ProgressNotification signal: '' extra: ('Downloading {1}' translated format: {fileName})]. - ifTrue:[ProgressNotification signal: '' extra: 'Downloading ', fileName]. ver := [repo versionNamed: fileName] ifError: []]]. ver ifNil: [ fileName := aMCVersionName versionName, '.mcz'. self class extraProgressInfo + ifTrue: [ProgressNotification signal: '' extra: ('Downloading {1}' translated format: {fileName})]. - ifTrue:[ProgressNotification signal: '' extra: 'Downloading ', fileName]. ver := repo versionNamed: fileName]. ^ver! Item was changed: ----- Method: MCConfigurationBrowser>>addDependency (in category 'dependencies') ----- addDependency (self pickWorkingCopiesSatisfying: [:each | (self includesPackage: each package) not]) do: [:wc | wc ancestors isEmpty + ifTrue: [self inform: ('You must save {1} first!! + Skipping this package' translated format: {wc packageName})] - ifTrue: [self inform: 'You must save ', wc packageName, ' first!! - Skipping this package'] ifFalse: [ self dependencies add: (MCVersionDependency package: wc package info: wc ancestors first)]]. self changed: #dependencyList; changed: #description! Item was changed: ----- Method: MCConfigurationBrowser>>addRepository (in category 'repositories') ----- addRepository (self pickRepositorySatisfying: [ : ea | (self repositories includes: ea) not ]) ifNotNil: + [ : repo | repo class supportsConfigurations ifFalse: [ ^ self inform: 'Not all of these repositories support MCConfigurations.' translated ]. - [ : repo | repo class supportsConfigurations ifFalse: [ ^ self inform: 'Not all of these repositories support MCConfigurations.' ]. self repositories add: repo. self changed: #repositoryList ]! Item was changed: ----- Method: MCConfigurationBrowser>>changedList (in category 'selection') ----- changedList self dependencyIndex > 0 ifTrue: [^self changed: #dependencyList]. self repositoryIndex > 0 ifTrue: [^self changed: #repositoryList]. + self error: 'nothing selected' translated! - self error: 'nothing selected'! Item was changed: ----- Method: MCConfigurationBrowser>>checkMissing (in category 'dependencies') ----- checkMissing | missing | missing := (self dependencies collect: [ : ea | ea versionInfo name ]) asSet. self repositories do: [ : eachRepository | eachRepository cacheAllFileNamesDuring: [ missing copy do: [ : eachVersionName | (eachRepository includesVersionNamed: eachVersionName) ifTrue: [ missing remove: eachVersionName ] ] ] ]. ^ missing isEmpty or: [ self selectDependency: missing anyOne. self confirm: (String streamContents: [ : strm | strm + nextPutAll: 'No repository found for' translated ; - nextPutAll: 'No repository found for' ; cr. missing do: [ : r | strm nextPutAll: r ; cr ]. + strm nextPutAll: 'Do you still want to store?' translated ]) ]! - strm nextPutAll: 'Do you still want to store?' ]) ]! Item was changed: ----- Method: MCConfigurationBrowser>>checkModified (in category 'dependencies') ----- checkModified | modified | modified := self dependencies select: [:dep | dep isFulfilled and: [dep package workingCopy modified]]. ^modified isEmpty or: [ self selectDependency: modified anyOne. self confirm: (String streamContents: [:strm | + strm nextPutAll: 'These packages are modified:' translated; cr. - strm nextPutAll: 'These packages are modified:'; cr. modified do: [:dep | strm nextPutAll: dep package name; cr]. + strm nextPutAll: 'Do you still want to store?' translated])]! - strm nextPutAll: 'Do you still want to store?'])] - ! Item was changed: ----- Method: MCConfigurationBrowser>>checkRepositories (in category 'repositories') ----- checkRepositories | bad | bad := self repositories reject: [:repo | repo class supportsConfigurations ]. ^bad isEmpty or: [ self selectRepository: bad first. self inform: (String streamContents: [:strm | + strm nextPutAll: 'Please remove these repositories:' translated; cr. - strm nextPutAll: 'Please remove these repositories:'; cr. bad do: [:r | strm nextPutAll: r description; cr]. + strm nextPutAll: '(only HTTP repositories are supported)' translated]). - strm nextPutAll: '(only HTTP repositories are supported)']). false]. ! Item was changed: ----- Method: MCConfigurationBrowser>>checkRepositoryTemplates (in category 'repositories') ----- checkRepositoryTemplates "unused for now - we only do HTTP" | bad | bad := self repositories select: [:repo | repo creationTemplate isNil]. ^bad isEmpty or: [ self selectRepository: bad first. self inform: (String streamContents: [:strm | + strm nextPutAll: 'Creation template missing for' translated; cr. - strm nextPutAll: 'Creation template missing for'; cr. bad do: [:r | strm nextPutAll: r description; cr]. + strm nextPutAll: 'Please fill in the details first!!' translated]). - strm nextPutAll: 'Please fill in the details first!!']). false]. ! Item was changed: ----- Method: MCConfigurationBrowser>>completeStoreAction (in category 'actions') ----- completeStoreAction "The store method will arrange for this to be called after the user has entered a comment for the configuration version being stored." self activeEditWindow: nil. "Close the editor window" self pickRepository ifNotNil: [:repo | configuration authorInitials: Utilities authorInitials. configuration timeStamp: (DateAndTime fromSeconds: DateAndTime now asSeconds) printString. configuration id: UUID new asString. (repo includesVersionNamed: configuration name) ifTrue: [self notify: ('The configuration does already exist in the repository you specified. If you proceed, it will be overwritten.\\Repository: {1}\Configuration: {2}\\Do you want to proceed anyway?' translated withCRs format: { repo description. configuration name })]. repo storeVersion: configuration. + self inform: ('Saved {1}' translated format: {configuration name})]! - self inform: 'Saved ', configuration name]! Item was changed: ----- Method: MCConfigurationBrowser>>description (in category 'description') ----- description self selectedDependency ifNotNil: [:dep | + ^ ('Package: {1}\{2}' withCRs translated format: {dep package name. dep versionInfo summary}) asText]. - ^ ('Package: ', dep package name, String cr, dep versionInfo summary) asText]. self selectedRepository ifNotNil: [:repo | ^repo creationTemplate ifNotNil: [repo creationTemplate asText] ifNil: [repo asCreationTemplate asText addAttribute: TextColor red]]. + ^'A configuration is a set of particular versions of packages. These can be used to manage multiple dependencies amongst packages when an update requires changes to multiple packages. One stores the current configuration and then modifies the various packages needing modification. On load, the image will be updated to at least the versions in the current configuration, hence providing the support needed to load the new packages.\\To create a new configuration first load the most up-to-date configuration in your repository (e.g., {1}), open that repository in the Monticello browser, scroll down to the "update" package, select the first entry in the list on the right hand side and click Browse, which will open the configuration in a new MCConfigurationBrowser. Then in the new MCConfigurationBrowser click Update, and choose "update all from image" from the pop-up menu. Click Store to save back to the repository. If required, one can add repositories to the browser to store the configuration in a different repository.' withCRs translated format: {MCHttpRepository trunkUrlString}! - ^('A configuration is a set of particular versions of packages. These can be used to manage multiple dependencies amongst packages when an update requires changes to multiple packages. One stores the current configuration and then modifies the various packages needing modification. On load, the image will be updated to at least the versions in the current configuration, hence providing the support needed to load the new packages.\\To create a new configuration first load the most up-to-date configuration in your repository (e.g.', MCHttpRepository trunkUrlString, '), open that repository in the Monticello browser, scroll down to the "update" package, select the first entry in the list on the right hand side and click Browse, which will open the configuration in a new MCConfigurationBrowser. Then in the new MCConfigurationBrowser click Update, and choose "update all from image" from the pop-up menu. Click Store to save back to the repository. If required, one can add reposit ories to the browser to store the configuration in a different repository.') withCRs! Item was changed: ----- Method: MCConfigurationBrowser>>description: (in category 'description') ----- description: aText self selectedRepository ifNotNil: [:repo | | new | new := MCRepository readFrom: aText asString. (new class = repo class and: [new description = repo description]) ifTrue: [ repo creationTemplate: aText asString. self changed: #description] ifFalse: [ + self inform: 'This does not match the previous definition!!' translated - self inform: 'This does not match the previous definition!!' ] ]. ! Item was changed: ----- Method: MCConfigurationBrowser>>enterVersionCommentAndCompleteWith:nameForRestore: (in category 'morphic ui') ----- enterVersionCommentAndCompleteWith: aConfigBrowser nameForRestore: originalName "Open an editor for comment entry. When text is accepted from the editor, ask if editing is done. If complete, then proceed to save the MCConfiguration. If cancelled, close the edit window and do nothing further. Otherwise leave the edit window open to allow further edits before proceeding to save the configuration." | editWindow | + editWindow := Project uiManager - editWindow := UIManager default edit: configuration comment + label: ('Enter or edit a comment for {1}' translated format: {configuration name}) - label: 'Enter or edit a comment for ', configuration name accept: [:aText | | editingComplete | editingComplete := UIManager default confirm: 'Comment accepted' translated + title: ('Comment for {1}' translated format: {configuration name}) - title: 'Comment for ' translated, configuration name trueChoice: 'Proceed to save configuration' translated falseChoice: 'Continue editing comment' translated. editingComplete ifNil: [ "cancel button pressed" configuration name: originalName. "cancelling, undo the changed name" Project current addDeferredUIMessage: [aConfigBrowser activeEditWindow ifNotNil: [ :win | win delete ]]] ifNotNil: [ editingComplete ifTrue: [configuration comment: aText asString. Project current addDeferredUIMessage: [aConfigBrowser completeStoreAction]] ifFalse: [ "edit window remains open" ]]]. + aConfigBrowser activeEditWindow: editWindow.! - aConfigBrowser activeEditWindow: editWindow. - ! Item was changed: ----- Method: MCConfigurationBrowser>>index: (in category 'selection') ----- index: anInteger self dependencyIndex > 0 ifTrue: [^self dependencyIndex: anInteger]. self repositoryIndex > 0 ifTrue: [^self repositoryIndex: anInteger]. + anInteger > 0 ifTrue: [self error: 'cannot select' translated]! - anInteger > 0 ifTrue: [self error: 'cannot select']! Item was changed: ----- Method: MCConfigurationBrowser>>pickName (in category 'morphic ui') ----- pickName | name | + name := Project uiManager + request: ('Name ({1} will be appended):' translated format: {'.' , self configuration writerClass extension}) - name := UIManager default - request: 'Name (.', self configuration writerClass extension, ' will be appended):' initialAnswer: self configuration suggestedNameOfNextVersion. ^ name isEmpty ifFalse: [name]! Item was changed: ----- Method: MCConfigurationBrowser>>pickRepositorySatisfying: (in category 'morphic ui') ----- pickRepositorySatisfying: aBlock | index list | list := MCRepositoryGroup default repositories select: aBlock. + index := Project uiManager chooseFrom: (list collect: [:ea | ea description]) + title: 'Repository:' translated. - index := UIManager default chooseFrom: (list collect: [:ea | ea description]) - title: 'Repository:'. ^ index = 0 ifFalse: [list at: index]! Item was changed: ----- Method: MCConfigurationBrowser>>pickWorkingCopiesSatisfying: (in category 'morphic ui') ----- pickWorkingCopiesSatisfying: aBlock | copies item | copies := (MCWorkingCopy allManagers select: aBlock) sort: [:a :b | a packageName <= b packageName]. + item := Project uiManager chooseFrom: #('match ...'),(copies collect: [:ea | ea packageName]) lines: #(1) title: 'Package:' translated. - item := UIManager default chooseFrom: #('match ...'),(copies collect: [:ea | ea packageName]) lines: #(1) title: 'Package:'. item = 1 ifTrue: [ | pattern | + pattern := Project uiManager request: 'Packages matching:' translated initialAnswer: '*'. - pattern := UIManager default request: 'Packages matching:' initialAnswer: '*'. ^pattern isEmptyOrNil ifTrue: [#()] ifFalse: [ (pattern includes: $*) ifFalse: [pattern := '*', pattern, '*']. copies select: [:ea | pattern match: ea packageName]] ]. ^ item = 0 ifTrue: [#()] ifFalse: [{copies at: item - 1}]! Item was changed: ----- Method: MCMcmUpdater class>>defaultUpdateURL (in category 'preferences') ----- defaultUpdateURL "The default update repository URL" <preference: 'Update URL' category: 'updates' description: 'The repository URL for loading updates' type: #String> ^ DefaultUpdateURL ifNil: [ self notify: 'There is no update URL configured. Proceed to use Squeak''s Trunk repository.' translated. + MCHttpRepository trunkUrlString]! - 'http://source.squeak.org/trunk']! Item was changed: ----- Method: MCMcmUpdater>>logUpdateOf:previousUpdateLevel:interactive: (in category 'updating') ----- logUpdateOf: config previousUpdateLevel: previousUpdateLevel interactive: interactive MCMcmUpdater default == self ifTrue: [ config setSystemVersion. interactive ifTrue: [ self inform: (self updateMessageFor: previousUpdateLevel)]. Transcript cr; + show: ('========== Update of {1} completed: ' translated format: {self repositoryName}); - show: '========== Update of ' translated, self repositoryName, ' completed: ' translated; show: previousUpdateLevel; show: ' -> ' ; show: SystemVersion current highestUpdate; show: ' =========='; cr ] ifFalse: [ interactive + ifTrue: [ self inform: ('Update of {1} completed.' translated format: {self repositoryName}) ]. + Transcript cr; show: ('========== Update of {1} completed. ==========' translated format: {self repositoryName}); cr ] - ifTrue: [ self inform: 'Update of ', self repositoryName, ' completed.' ]. - Transcript cr; show: '========== Update of ' translated, self repositoryName, ' completed. ==========' translated; cr ] ! Item was changed: ----- Method: MCMcmUpdater>>updateFromRepository (in category 'updating') ----- updateFromRepository | config repo | repo := self getRepositoryFromRepositoryGroup. repo cacheAllFileNamesDuring: [ | updateList | updateList := self updateListFor: repo. "Proceed only if there are updates available at all." updateList ifNotEmpty: [ updateList := self refreshUpdateMapFor: repo with: updateList. "Now process each update file. Check if we have all dependencies and if not, load the entire configuration (this is mostly to skip older updates quickly)" updateList do:[:assoc| + ProgressNotification signal: '' extra: ('Processing {1}' translated format: {assoc value}). - ProgressNotification signal: '' extra: 'Processing ', assoc value. config := repo versionNamed: assoc value. self updateFromConfig: config. self lastUpdateMap at: repo description put: assoc key. + ] displayingProgress: 'Processing configurations' translated. - ] displayingProgress: 'Processing configurations'. "We've loaded all the provided update configurations. Use the latest configuration to update all the remaining packages." (self useLatestPackagesFrom: repo) ifTrue: [ config updateFromRepositories. config upgrade]. ]]. ^ config ! Item was changed: ----- Method: MCMcmUpdater>>updateFromRepository:upTo: (in category 'updating') ----- updateFromRepository: repository upTo: versionNumber | config | + config := nil. repository cacheAllFileNamesDuring: [ | updateList | updateList := self updateListFor: repository. "Proceed only if there are updates available at all." updateList ifNotEmpty: [ updateList := self refreshUpdateMapFor: repository with: updateList. "Now process each update file. Check if we have all dependencies and if not, load the entire configuration (this is mostly to skip older updates quickly)" updateList do:[:assoc| assoc key > versionNumber ifTrue: [^config]. + ProgressNotification signal: '' extra: ('Processing ' translated format: {assoc value}). - ProgressNotification signal: '' extra: 'Processing ', assoc value. config := repository versionNamed: assoc value. self updateFromConfig: config. self lastUpdateMap at: repository description put: assoc key. + ] displayingProgress: 'Processing configurations' translated. - ] displayingProgress: 'Processing configurations'. ]]. ^config ! Item was changed: ----- Method: MCMcmUpdater>>updateListFor: (in category 'private') ----- updateListFor: repo | updateList allNames minVersion | updateList := OrderedCollection new. minVersion := self lastUpdateMap at: repo description ifAbsent: [0]. "Find all the update-*.mcm files" + allNames := ('Checking {1}' translated format: {repo description}) - allNames := 'Checking ', repo description displayProgressFrom: 0 to: 1 during: [:bar| bar value: 0. repo allFileNamesOrCache ]. allNames do: [:fileName | | version | ((fileName endsWith: '.mcm') and: [fileName packageAndBranchName = self updateMapName and: [(version := fileName versionNumber) >= minVersion]]) ifTrue: [updateList add: version -> fileName]]. ^updateList sort!

1 0

Questions regarding translations
by christoph.thiede＠student.hpi.uni-potsdam.de 03 Jan '22

03 Jan '22

Hi all! I have some quick questions regarding proper use of #translated & friends: 1. When should you use #translatedNoop rather than #translated? 2. Should you only use #translated right after a string literal literal or it is also fine to write things such as: (aBoolean ifTrue: ['on'] ifFalse: ['off']) translated. #('yes' 'no' 'cancel') collect: #translated. menu addTranslatedList: ... Some examples like the above are already in the Trunk, but on the other hand, I do not know how the translator engine should find the locale strings in this case. Thanks in advance! Best, Christoph --- Sent from Squeak Inbox Talk

3 2

The Inbox: Monticello-ct.729.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

A new version of Monticello was added to project The Inbox: http://source.squeak.org/inbox/Monticello-ct.729.mcz ==================== Summary ==================== Name: Monticello-ct.729 Author: ct Time: 17 September 2020, 7:04:53.385813 pm UUID: 5eea47cc-405e-7841-9544-0f57a9b92fa0 Ancestors: Monticello-cmm.726 Proposal: Enhance truncation of "newer versions avaiable" warning (and make it multilingual-ready) =============== Diff against Monticello-cmm.726 =============== Item was changed: ----- Method: MCWorkingCopyBrowser>>checkForNewerVersions (in category 'actions') ----- checkForNewerVersions + "Answer true if there are no newer versions preventing us from saving a version." + | newer | newer := workingCopy possiblyNewerVersionsIn: self repository. + + newer ifEmpty: [^ true]. + + ^ self confirm: ('CAUTION!! {1}:\{2}\Do you really want to save this version?' withCRs translated format: { + newer size = 1 + ifTrue: ['This version in the repository may be newer' translated] + ifFalse: ['These {1} versions in the repository may be newer' translated format: {newer size}]. + (newer size > 3 + ifFalse: [newer] + ifTrue: [(newer first: 3) , {'...'} , {newer last}]) asCommaString withNoLineLongerThan: 150 + })! - ^ newer isEmpty or: [ - self confirm: 'CAUTION!! These versions in the repository may be newer:', - String cr, ((newer asCommaString withNoLineLongerThan: 150) truncateWithElipsisTo: 5 * 149), String cr, - 'Do you really want to save this version?'].!

4 4

The Trunk: Monticello-ct.764.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-ct.764.mcz ==================== Summary ==================== Name: Monticello-ct.764 Author: ct Time: 3 January 2022, 9:40:50.200397 pm UUID: 861868bb-b96a-3144-959b-a00a7e62abb0 Ancestors: Monticello-eem.763, Monticello-ct.729 Improves multilingual support. =============== Diff against Monticello-eem.763 =============== Item was changed: ----- Method: MCVersionHistoryBrowser>>defaultLabel (in category 'morphic ui') ----- defaultLabel + ^ '{1} History' translated format: {ancestry name}! - ^ ancestry name, ' History'! Item was changed: ----- Method: MCVersionHistoryBrowser>>searchHistory (in category 'morphic ui') ----- searchHistory + (Project uiManager - (UIManager default edit: (String streamContents: [:s| self selectedInfo topologicalAncestors do: [:versionInfo | s nextPutAll: versionInfo summary] separatedBy: [s cr; cr]]) + label: ('Version History: {1}' translated format: {self selectedInfo versionName})) + extent: (0.5(a)0.9) * Display height! - label: 'Version History: ', self selectedInfo versionName) - extent: (0.5(a)0.9) * Display height! Item was changed: ----- Method: MCVersionHistoryBrowser>>viewChanges:snapshot:relativeTo:snapshot: (in category 'morphic ui') ----- viewChanges: ancestorInfo snapshot: ancestorSnapshot relativeTo: baseInfo snapshot: baseSnapshot "Note that the patchLabel will be parsed in MCPatchBrowser>>installSelection, so don't translate it!!" | patch patchLabel | + patchLabel := 'changes between {1} and {2}' translated format: { baseInfo name. ancestorInfo name }. - patchLabel := 'changes between {1} and {2}' format: { baseInfo name. ancestorInfo name }. patch := ancestorSnapshot patchRelativeToBase: baseSnapshot. (MCPatchBrowser forPatch: patch) label: patchLabel; show! Item was changed: ----- Method: MCWorkingCopyBrowser>>addWorkingCopy (in category 'actions') ----- addWorkingCopy |name| + name := Project uiManager request: 'Name of package:' translated. - name := UIManager default request: 'Name of package:'. name isEmptyOrNil ifFalse: [PackageInfo registerPackageName: name. workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name). workingCopyWrapper := nil. self repositorySelection: 0]. self workingCopyListChanged; changed: #workingCopySelection; changed: #repositoryList. self changedButtons.! Item was changed: ----- Method: MCWorkingCopyBrowser>>backportChanges (in category 'actions') ----- backportChanges self canBackport ifFalse: [^self]. workingCopy ifNotNil: + [workingCopy needsSaving ifTrue: [^ self inform: 'You must save the working copy before backporting.' translated]. - [workingCopy needsSaving ifTrue: [^ self inform: 'You must save the working copy before backporting.']. self pickAncestorVersionInfo ifNotNil: [:baseVersionInfo | workingCopy backportChangesTo: baseVersionInfo]]! Item was changed: ----- Method: MCWorkingCopyBrowser>>checkForNewerVersions (in category 'actions') ----- checkForNewerVersions + "Answer true if there are no newer versions preventing us from saving a version." + | newer | newer := workingCopy possiblyNewerVersionsIn: self repository. + + newer ifEmpty: [^ true]. + + ^ self confirm: ('CAUTION!! {1}:\\ {2}\\Do you really want to save this version?' withCRs translated format: { + newer size = 1 + ifTrue: ['This version in the repository may be newer' translated] + ifFalse: ['These {1} versions in the repository may be newer' translated format: {newer size}]. + newer asCommaString withNoLineLongerThan: 150})! - ^ newer isEmpty or: [ - self confirm: 'CAUTION!! These versions in the repository may be newer:', - String cr, ((newer asCommaString withNoLineLongerThan: 150) truncateWithElipsisTo: 5 * 149), String cr, - 'Do you really want to save this version?'].! Item was changed: ----- Method: MCWorkingCopyBrowser>>defaultLabel (in category 'morphic ui') ----- defaultLabel + ^ 'Monticello Browser' translated! - ^ 'Monticello Browser'! Item was changed: ----- Method: MCWorkingCopyBrowser>>editRepository (in category 'actions') ----- editRepository | newRepo | newRepo := self repository openAndEditTemplateCopy. newRepo ifNotNil: [ newRepo class = self repository class ifTrue: [ self repository copyFrom: newRepo. self changed: #repositoryList ] + ifFalse: [self inform: 'Must not change repository type!!' translated]]! - ifFalse: [self inform: 'Must not change repository type!!']] - ! Item was changed: ----- Method: MCWorkingCopyBrowser>>editScript: (in category 'morphic ui') ----- editScript: scriptSymbol + | script | + script := workingCopy packageInfo perform: scriptSymbol. + script openLabel: ('{1} of the Package {2}' translated format: {scriptSymbol. workingCopy package name}).! - | script | - script := workingCopy packageInfo perform: scriptSymbol. - script openLabel: scriptSymbol asString, ' of the Package ', workingCopy package name.! Item was changed: ----- Method: MCWorkingCopyBrowser>>flushCachedVersions (in category 'actions') ----- flushCachedVersions | beforeBytes afterBytes beforeVersions afterVersions | Cursor wait showWhile: [ Smalltalk garbageCollect. beforeBytes := Smalltalk bytesLeft: true. beforeVersions := MCVersion allSubInstances size. MCFileBasedRepository flushAllCaches. afterBytes := Smalltalk bytesLeft: true. afterVersions := MCVersion allSubInstances size. ]. + ^self inform: ('{1} versions flushed\{2} bytes reclaimed' translated format: {beforeVersions - afterVersions. beforeBytes - afterBytes})! - ^self inform: (beforeVersions - afterVersions) asString, ' versions flushed', String cr, - (beforeBytes - afterBytes) asBytesDescription, ' bytes reclaimed'! Item was changed: ----- Method: MCWorkingCopyBrowser>>flushCachedVersionsAncestry (in category 'actions') ----- flushCachedVersionsAncestry | beforeBytes afterBytes beforeVersions afterVersions beforeInfos afterInfos | Cursor wait showWhile: [ beforeBytes := Smalltalk garbageCollect. beforeVersions := MCVersion allSubInstances size. beforeInfos := MCVersionInfo instanceCount. MCFileBasedRepository flushAllCaches. MCWorkingCopy stubAllAncestry. afterBytes := Smalltalk garbageCollect. afterVersions := MCVersion allSubInstances size. afterInfos := MCVersionInfo instanceCount ]. self inform: + ('{1} versions flushed\{2\ infos flushed\{3} reclaimed' translated + format: {beforeVersions - afterVersions. beforeInfos - afterInfos. (afterBytes - beforeBytes) asBytesDescription}).! - (beforeVersions-afterVersions) asString, ' versions flushed', - String cr, (beforeInfos-afterInfos), ' infos flushed', - String cr, (afterBytes-beforeBytes) asBytesDescription, ' reclaimed'! Item was changed: ----- Method: MCWorkingCopyBrowser>>newRepository (in category 'actions') ----- newRepository | types index | types := MCRepository allConcreteSubclasses asArray. + index := Project uiManager chooseFrom: (types collect: [:ea | ea description]) + title: 'Repository type:' translated. - index := UIManager default chooseFrom: (types collect: [:ea | ea description]) - title: 'Repository type:'. ^ index = 0 ifFalse: [(types at: index) morphicConfigure]! Item was changed: ----- Method: MCWorkingCopyBrowser>>pickAncestorVersionInfo (in category 'morphic ui') ----- pickAncestorVersionInfo | ancestors index | ancestors := workingCopy ancestry breadthFirstAncestors. + index := Project uiManager chooseFrom: (ancestors collect: [:ea | ea name]) + title: 'Ancestor:' translated. - index := UIManager default chooseFrom: (ancestors collect: [:ea | ea name]) - title: 'Ancestor:'. ^ index = 0 ifFalse: [ ancestors at: index]! Item was changed: ----- Method: MCWorkingCopyBrowser>>pickRepositorySatisfying: (in category 'morphic ui') ----- pickRepositorySatisfying: aBlock | repos index | repos := MCRepositoryGroup default repositories select: aBlock. + index := Project uiManager chooseFrom: (repos collect: [:ea | ea description]) + title: 'Repository:' translated. - index := UIManager default chooseFrom: (repos collect: [:ea | ea description]) - title: 'Repository:'. ^ index = 0 ifFalse: [repos at: index]! Item was changed: ----- Method: MCWorkingCopyBrowser>>pickWorkingCopySatisfying: (in category 'morphic ui') ----- pickWorkingCopySatisfying: aBlock | copies index | copies := self workingCopies select: aBlock. copies isEmpty ifTrue: [ ^nil ]. + index := Project uiManager chooseFrom: (copies collect: [:ea | ea packageName]) + title: 'Package:' translated. - index := UIManager default chooseFrom: (copies collect: [:ea | ea packageName]) - title: 'Package:'. ^ index = 0 ifFalse: [ copies at: index]! Item was changed: ----- Method: MCWorkingCopyBrowser>>recompilePackage (in category 'actions') ----- recompilePackage (workingCopy withEnvironmentActiveDo: [workingCopy package packageInfo methods]) do: [:ea | ea actualClass recompile: ea methodSymbol] + displayingProgress: 'Recompiling...' translated.! - displayingProgress: 'Recompiling...'! Item was changed: ----- Method: MCWorkingCopyBrowser>>renamePackage (in category 'actions') ----- renamePackage | newName | workingCopy ifNil: + [ self inform: 'Please select a package to be renamed.' translated. - [ UIManager inform: 'Please select a package to be renamed.'. ^ self ]. workingCopy modified ifTrue: + [ self inform: 'Only unmodified packages should be renamed.' translated. - [ UIManager inform: 'Only unmodified packages should be renamed.'. ^ self ]. + newName := Project uiManager + request: 'New name of package:' translated - newName := UIManager default - request: 'New name of package:' initialAnswer: workingCopy packageName. newName isEmptyOrNil ifFalse: [ | newWorkingCopy | newWorkingCopy := workingCopy renameToBe: newName. workingCopy package snapshot definitions ifEmpty: [ "It worked." workingCopy unregister. workingCopy := newWorkingCopy. self repositorySelection: 0. self workingCopyListChanged ; changed: #workingCopySelection ; changed: #repositoryList. self changedButtons ] ifNotEmpty: [ "It didn't work, browse the remaining definitions." self browseWorkingCopy ] ]! Item was changed: ----- Method: MCWorkingCopyBrowser>>revertPackage (in category 'actions') ----- revertPackage self pickAncestorVersionInfo ifNotNil: [:info | (self repositoryGroup versionWithInfo: info + ifNone: [^self inform: ('No repository found for {1}' translated format: {info name})] - ifNone: [^self inform: 'No repository found for ', info name] ) load]! Item was changed: ----- Method: MCWorkingCopyBrowser>>searchHistory (in category 'actions') ----- searchHistory workingCopy ifNotNil: [(UIManager default edit: (String streamContents: [:s| "Ignore the initial MCWorkingAncestry instance." workingCopy ancestry topologicalAncestors allButFirst do: [:versionInfo| s nextPutAll: versionInfo summary] separatedBy: [s cr; cr"; next: 32 put: $-; cr; cr"]]) + label: ('Version History: {1}' translated format: {workingCopy packageName})) - label: 'Version History: ', workingCopy packageName) extent: (0.6@1) * Display height * 0.9]! Item was changed: ----- Method: MCWorkingCopyBrowser>>viewChanges (in category 'actions') ----- viewChanges | patch | self canSave ifTrue: [patch := workingCopy changesRelativeToRepository: self repository withCache. patch isNil ifTrue: [ ^self ]. patch isEmpty ifTrue: [ workingCopy modified: false. self inform: ('No changes between your working copy of the package\\ {1}\\ and the repository at location\\ {2}' withCRs translated asText format: { workingCopy packageName asText allBold. self repository description asText allBold })] ifFalse: [ workingCopy modified: true. (MCPatchBrowser forPatch: patch) + label: ('Patch Browser: {1}' translated format: {workingCopy description}); - label: 'Patch Browser: ', workingCopy description; environmentInDisplayingImage: workingCopy environment; show ] ]! Item was changed: ----- Method: MCWorkingCopyBrowser>>viewHistory (in category 'actions') ----- viewHistory workingCopy ifNotNil: [(MCWorkingHistoryBrowser new ancestry: workingCopy ancestry; package: workingCopy package) + label: ('Version History: {1}' translated format: {workingCopy packageName}); - label: 'Version History: ', workingCopy packageName; show]!

1 0

The Inbox: Kernel-ct.1442.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

A new version of Kernel was added to project The Inbox: http://source.squeak.org/inbox/Kernel-ct.1442.mcz ==================== Summary ==================== Name: Kernel-ct.1442 Author: ct Time: 3 January 2022, 9:25:00.293397 pm UUID: 1c8eb404-f420-9f48-99fa-32c965fb5491 Ancestors: Kernel-mt.1441 Improves multilingual support in common error messages on Object. Uploaded to the inbox because I am not sure whether any of these places should NOT invoke Get-Text to avoid infinite recursions. I already excluded the error selectors in the private category and #primitiveFailed: for this reason. How far do we want to go with multilingual support in low-level Kernel? =============== Diff against Kernel-mt.1441 =============== Item was changed: ----- Method: AdditionalMethodState>>copyWith: (in category 'copying') ----- copyWith: aPropertyOrPragma "<Association|Pragma>" "Answer a copy of the receiver which includes aPropertyOrPragma" | bs copy | (Association == aPropertyOrPragma class or: [Pragma == aPropertyOrPragma class]) ifFalse: + [self error: ('{1} instances should hold only Associations or Pragmas.' translated format: {self class name})]. - [self error: self class name, ' instances should hold only Associations or Pragmas.']. "no need to initialize here; we're copying all inst vars" copy := self class basicNew: (bs := self basicSize) + 1. 1 to: bs do: [:i| copy basicAt: i put: (self basicAt: i) shallowCopy]. copy basicAt: bs + 1 put: aPropertyOrPragma. 1 to: self class instSize do: [:i| copy instVarAt: i put: (self instVarAt: i)]. ^copy! Item was changed: ----- Method: Object>>assert: (in category 'error handling') ----- assert: aBlock "Throw an assertion error if aBlock does not evaluates to true." + aBlock value ifFalse: [AssertionFailure signal: 'Assertion failed' translated]! - aBlock value ifFalse: [AssertionFailure signal: 'Assertion failed']! Item was changed: ----- Method: Object>>backwardCompatibilityOnly: (in category 'error handling') ----- backwardCompatibilityOnly: explanationString "Warn that the sending method has been deprecated. Methods that are tagt with #backwardCompatibility: are kept for compatibility." Deprecation signalForContext: thisContext sender + message: ' (but will be kept for compatibility)' translated - message: ' (but will be kept for compatibility)' explanation: explanationString! Item was changed: ----- Method: Object>>caseError (in category 'error handling') ----- caseError "Report an error from an in-line or explicit case statement." + self error: ('Case not found ({1}), and no otherwise clause' translated format: {self printString})! - self error: ('Case not found ({1}), and no otherwise clause' format: {self printString})! Item was changed: ----- Method: Object>>doesNotUnderstand: (in category 'error handling') ----- doesNotUnderstand: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector). Raise the MessageNotUnderstood signal. If it is caught, answer the result supplied by the exception handler. If it is not caught, answer the result of resending the message within a guard for infinite recursion. This allows, for example, the programmer to implement the method and continue." "Testing: (3 activeProcess)" | exception resumeValue | (exception := MessageNotUnderstood new) message: aMessage; receiver: self. resumeValue := exception signal. ^exception reachedDefaultHandler "i.e. exception was not caught..." ifTrue: [[aMessage sentTo: self] on: MessageNotUnderstood do: [:ex| (self == ex receiver and: [aMessage hasIdenticalContentsAs: ex message]) ifFalse: [ex pass]. + self error: 'infinite recursion in doesNotUnderstand:' translated]] - self error: 'infinite recursion in doesNotUnderstand:']] ifFalse: [resumeValue]! Item was changed: ----- Method: Object>>error (in category 'error handling') ----- error "Throw a generic Error exception." + ^self error: 'Error!!' translated.! - ^self error: 'Error!!'.! Item was changed: ----- Method: Object>>shouldBeImplemented (in category 'error handling') ----- shouldBeImplemented "Announce that this message should be implemented" + ^ NotImplemented signal: ('{1} or a superclass should implement {2}' translated format: {self className. thisContext sender selector})! - ^ NotImplemented signal: ('{1} or a superclass should implement {2}' format: {self className. thisContext sender selector})! Item was changed: ----- Method: Object>>shouldNotImplement (in category 'error handling') ----- shouldNotImplement "Announce that, although the receiver inherits this message, it should not implement it." + NotImplemented signal: ('{1} is not a message appropriate for a {2}' translated format: {thisContext sender selector. self className}).! - NotImplemented signal: ('{1} is not a message appropriate for a {2}' format: {thisContext sender selector. self className}).! Item was changed: ----- Method: Object>>subclassResponsibility (in category 'error handling') ----- subclassResponsibility "This message sets up a framework for the behavior of the class' subclasses. Announce that the subclass should have implemented this message." ^ SubclassResponsibility signal: ('My {1} subclass should have overridden {2}' + translated format: {self className. thisContext sender selector}).! - format: {self className. thisContext sender selector}).! Item was changed: ----- Method: Object>>traitConflict (in category 'error handling') ----- traitConflict + self error: 'A class or trait does not properly resolve a conflict between multiple traits it uses.' translated! - self error: 'A class or trait does not properly resolve a conflict between multiple traits it uses.'!

1 0

The Trunk: Graphics-ct.457.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-ct.457.mcz ==================== Summary ==================== Name: Graphics-ct.457 Author: ct Time: 3 January 2022, 9:19:39.486397 pm UUID: fd7bbdad-6898-7041-8182-7fea4f36fbee Ancestors: Graphics-mt.456 Improves multilingual support in Graphics-Files. Also includes a few recategorizations and removes two outdated helper methods. =============== Diff against Graphics-mt.456 =============== Item was changed: ----- Method: BMPReadWriter>>nextPutImage: (in category 'writing') ----- nextPutImage: aForm | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen pixline | depth := aForm depth. depth := #(1 4 8 32 ) detect: [ :each | each >= depth]. image := aForm asFormOfDepth: depth. image unhibernate. bhSize := 14. "# bytes in file header" biSize := 40. "info header size in bytes" biWidth := image width. biHeight := image height. biClrUsed := depth = 32 ifTrue: [0] ifFalse:[1 << depth]. "No. color table entries" bfOffBits := biSize + bhSize + (4*biClrUsed). rowBytes := ((depth min: 24) * biWidth + 31 // 32) * 4. biSizeImage := biHeight * rowBytes. "Write the file header" stream position: 0. stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" stream nextLittleEndianNumber: 4 put: 0. "bfReserved" stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" stream position: bhSize. stream nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" stream nextLittleEndianNumber: 4 put: image width. "biWidth" stream nextLittleEndianNumber: 4 put: image height. "biHeight" stream nextLittleEndianNumber: 2 put: 1. "biPlanes" stream nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" stream nextLittleEndianNumber: 4 put: 0. "biCompression" stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" stream nextLittleEndianNumber: 4 put: biClrUsed. stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues := image colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [:i | rgb := colorValues at: i. 0 to: 24 by: 8 do: [:j | stream nextPut: (rgb >> j bitAnd: 16rFF)]]]. depth < 32 ifTrue: [ "depth = 1, 4 or 8." data := image bits asByteArray. ppw := 32 // depth. scanLineLen := biWidth + ppw - 1 // ppw * 4. "# of bytes in line" 1 to: biHeight do: [:i | stream next: scanLineLen putAll: data startingAt: (biHeight-i)*scanLineLen+1. ]. ] ifFalse: [ data := image bits. pixline := ByteArray new: (((biWidth * 3 + 3) // 4) * 4). 1 to: biHeight do:[:i | self store24BitBmpLine: pixline from: data startingAt: (biHeight-i)*biWidth+1 width: biWidth. stream nextPutAll: pixline. ]. ]. + stream position = (bfOffBits + biSizeImage) ifFalse: [self error: 'Write failure' translated]. - stream position = (bfOffBits + biSizeImage) ifFalse: [self error:'Write failure']. stream close.! Item was changed: ----- Method: GIFReadWriter class>>grabScreenAndSaveOnDisk (in category 'examples') ----- grabScreenAndSaveOnDisk "GIFReadWriter grabScreenAndSaveOnDisk" | form fileName | form := Form fromUser. form bits size = 0 ifTrue: [^Beeper beep]. fileName := FileDirectory default nextNameFor: 'Squeak' extension: 'gif'. + Project uiManager + informUser: ('Writing {1}' translated format: {fileName}) + during: [GIFReadWriter putForm: form onFileNamed: fileName].! - UIManager default informUser: 'Writing ' , fileName - during: [GIFReadWriter putForm: form onFileNamed: fileName]! Item was changed: ----- Method: GIFReadWriter>>nextImage (in category 'accessing') ----- nextImage "Read in the next GIF image from the stream." | f thisImageColorTable | localColorTable := nil. self readHeader. f := self readBody. self close. + f == nil ifTrue: [^ self error: 'corrupt GIF file' translated]. - f == nil ifTrue: [^ self error: 'corrupt GIF file']. thisImageColorTable := localColorTable ifNil: [colorPalette]. transparentIndex ifNotNil: [ transparentIndex + 1 > thisImageColorTable size ifTrue: [ thisImageColorTable := thisImageColorTable forceTo: transparentIndex + 1 paddingWith: Color white ]. thisImageColorTable at: transparentIndex + 1 put: Color transparent ]. f colors: thisImageColorTable. ^ f ! Item was changed: ----- Method: GIFReadWriter>>readBitData (in category 'private-decoding') ----- readBitData "using modified Lempel-Ziv Welch algorithm." | outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c packedBits hasLocalColor localColorSize maxOutCodes | maxOutCodes := 4096. offset := self readWord@self readWord. "Image Left@Image Top" width := self readWord. height := self readWord. "--- Local Color Table Flag 1 Bit Interlace Flag 1 Bit Sort Flag 1 Bit Reserved 2 Bits Size of Local Color Table 3 Bits ----" packedBits := self next. interlace := (packedBits bitAnd: 16r40) ~= 0. hasLocalColor := (packedBits bitAnd: 16r80) ~= 0. localColorSize := 1 bitShift: ((packedBits bitAnd: 16r7) + 1). hasLocalColor ifTrue: [localColorTable := self readColorTable: localColorSize]. pass := 0. xpos := 0. ypos := 0. rowByteSize := ((width + 3) // 4) * 4. remainBitCount := 0. bufByte := 0. bufStream := ReadStream on: ByteArray new. outCodes := ByteArray new: maxOutCodes + 1. outCount := 0. bitMask := (1 bitShift: bitsPerPixel) - 1. prefixTable := Array new: 4096. suffixTable := Array new: 4096. initCodeSize := self next. self setParameters: initCodeSize. + bitsPerPixel > 8 ifTrue: [^self error: ('never heard of a GIF that deep (depth = {1})' translated format: {bitsPerPixel})]. - bitsPerPixel > 8 ifTrue: [^self error: 'never heard of a GIF that deep']. bytes := ByteArray new: rowByteSize * height. [(code := self readCode) = eoiCode] whileFalse: [code = clearCode ifTrue: [self setParameters: initCodeSize. curCode := oldCode := code := self readCode. finChar := curCode bitAnd: bitMask. "Horrible hack to avoid running off the end of the bitmap. Seems to cure problem reading some gifs!!? tk 6/24/97 20:16" xpos = 0 ifTrue: [ ypos < height ifTrue: [ bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]] ifFalse: [bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]. self updatePixelPosition] ifFalse: [curCode := inCode := code. curCode >= freeCode ifTrue: [curCode := oldCode. outCodes at: (outCount := outCount + 1) put: finChar]. [curCode > bitMask] whileTrue: [outCount > maxOutCodes + ifTrue: [^self error: ('corrupt GIF file ({1})' translated format: {'OutCount'})]. - ifTrue: [^self error: 'corrupt GIF file (OutCount)']. outCodes at: (outCount := outCount + 1) put: (suffixTable at: curCode + 1). curCode := prefixTable at: curCode + 1]. finChar := curCode bitAnd: bitMask. outCodes at: (outCount := outCount + 1) put: finChar. i := outCount. [i > 0] whileTrue: ["self writePixel: (outCodes at: i) to: bits" bytes at: (ypos * rowByteSize) + xpos + 1 put: (outCodes at: i). self updatePixelPosition. i := i - 1]. outCount := 0. prefixTable at: freeCode + 1 put: oldCode. suffixTable at: freeCode + 1 put: finChar. oldCode := inCode. freeCode := freeCode + 1. self checkCodeSize]]. prefixTable := suffixTable := nil. f := ColorForm extent: width@height depth: 8. f bits copyFromByteArray: bytes. "Squeak can handle depths 1, 2, 4, and 8" bitsPerPixel > 4 ifTrue: [^ f]. "reduce depth to save space" c := ColorForm extent: width@height depth: (bitsPerPixel = 3 ifTrue: [4] ifFalse: [bitsPerPixel]). f displayOn: c. + ^ c! - ^ c - ! Item was changed: ----- Method: GIFReadWriter>>readHeader (in category 'private-decoding') ----- readHeader | is89 byte hasColorMap | (self hasMagicNumber: 'GIF87a' asByteArray) ifTrue: [is89 := false] ifFalse: [(self hasMagicNumber: 'GIF89a' asByteArray) ifTrue: [is89 := true] + ifFalse: [^ self error: 'This does not appear to be a GIF file' translated]]. - ifFalse: [^ self error: 'This does not appear to be a GIF file']]. self readWord. "skip Screen Width" self readWord. "skip Screen Height" byte := self next. hasColorMap := (byte bitAnd: 16r80) ~= 0. bitsPerPixel := (byte bitAnd: 7) + 1. byte := self next. "skip background color." self next ~= 0 ifTrue: [is89 + ifFalse: [^self error: ('corrupt GIF file ({1})' translated format: {'screen descriptor'})]]. - ifFalse: [^self error: 'corrupt GIF file (screen descriptor)']]. hasColorMap ifTrue: [colorPalette := self readColorTable: (1 bitShift: bitsPerPixel)] ifFalse: ["Transcript cr; show: 'GIF file does not have a color map.'." colorPalette := nil "Palette monochromeDefault"].! Item was changed: ----- Method: GIFReadWriter>>updatePixelPosition (in category 'private') ----- updatePixelPosition (xpos := xpos + 1) >= width ifFalse: [^self]. xpos := 0. interlace ifFalse: [ypos := ypos + 1. ^self]. pass = 0 ifTrue: [(ypos := ypos + 8) >= height ifTrue: [pass := pass + 1. ypos := 4]. ^self]. pass = 1 ifTrue: [(ypos := ypos + 8) >= height ifTrue: [pass := pass + 1. ypos := 2]. ^self]. pass = 2 ifTrue: [(ypos := ypos + 4) >= height ifTrue: [pass := pass + 1. ypos := 1]. ^self]. pass = 3 ifTrue: [ypos := ypos + 2. ^self]. + ^pass caseError! - ^self error: 'can''t happen'! Item was changed: ----- Method: ImageReadWriter class>>formFromStream: (in category 'image reading/writing') ----- formFromStream: aBinaryStream "Answer a ColorForm stored on the given stream. closes the stream" | reader readerClass form | readerClass := self withAllSubclasses detect: [:subclass | aBinaryStream reset. subclass understandsImageFormat: aBinaryStream] ifNone: [ aBinaryStream close. + ^self error: 'image format not recognized' translated]. - ^self error: 'image format not recognized']. aBinaryStream reset. reader := readerClass new on: aBinaryStream. Cursor read showWhile: [ form := reader nextImage. reader close]. ^ form ! Item was changed: ----- Method: ImageReadWriter>>changePadOfBits:width:height:depth:from:to: (in category 'private') ----- changePadOfBits: bits width: width height: height depth: depth from: oldPad to: newPad "Change padding size of bits." | srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset | (#(8 16 32) includes: oldPad) + ifFalse: [^self error: ('Invalid pad: {1}' translated format: {oldPad})]. - ifFalse: [^self error: 'Invalid pad: ', oldPad printString]. (#(8 16 32) includes: newPad) + ifFalse: [^self error: ('Invalid pad: {1}' translated format: {newPad})]. - ifFalse: [^self error: 'Invalid pad: ', newPad printString]. srcRowByteSize := width * depth + oldPad - 1 // oldPad * (oldPad / 8). srcRowByteSize * height = bits size + ifFalse: [^self error: 'Incorrect bitmap array size.' translated]. - ifFalse: [^self error: 'Incorrect bitmap array size.']. dstRowByteSize := width * depth + newPad - 1 // newPad * (newPad / 8). newBits := ByteArray new: dstRowByteSize * height. srcRowBase := 1. rowEndOffset := dstRowByteSize - 1. 1 to: newBits size by: dstRowByteSize do: [:dstRowBase | newBits replaceFrom: dstRowBase to: dstRowBase + rowEndOffset with: bits startingAt: srcRowBase. srcRowBase := srcRowBase + srcRowByteSize]. ^newBits! Item was changed: ----- Method: ImageReadWriter>>unpackBits:depthTo8From:with:height:pad: (in category 'private') ----- unpackBits: bits depthTo8From: depth with: width height: height pad: pad "Unpack bits of depth 1, 2, or 4 image to it of depth 8 image." | bitMask pixelInByte bitsWidth upBitsWidth stopWidth trailingSize upBits bitIndex upBitIndex val | (#(1 2 4) includes: depth) + ifFalse: [^self error: 'depth must be 1, 2, or 4' translated]. - ifFalse: [^self error: 'depth must be 1, 2, or 4']. (#(8 16 32) includes: pad) + ifFalse: [^self error: 'pad must be 8, 16, or 32' translated]. - ifFalse: [^self error: 'pad must be 8, 16, or 32']. bitMask := (1 bitShift: depth) - 1. pixelInByte := 8 / depth. bitsWidth := width * depth + pad - 1 // pad * (pad / 8). upBitsWidth := width * 8 + pad - 1 // pad * (pad / 8). stopWidth := width * depth + 7 // 8. trailingSize := width - (stopWidth - 1 * pixelInByte). upBits := ByteArray new: upBitsWidth * height. 1 to: height do: [:i | bitIndex := i - 1 * bitsWidth. upBitIndex := i - 1 * upBitsWidth. 1 to: stopWidth - 1 do: [:j | val := bits at: (bitIndex := bitIndex + 1). upBitIndex := upBitIndex + pixelInByte. 1 to: pixelInByte do: [:k | upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask). val := val bitShift: depth negated]]. val := (bits at: (bitIndex := bitIndex + 1)) bitShift: depth negated * (pixelInByte - trailingSize). upBitIndex := upBitIndex + trailingSize. 1 to: trailingSize do: [:k | upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask). val := val bitShift: depth negated]]. ^ upBits ! Item was changed: ----- Method: JPEGReadStream>>decodeValueFrom: (in category 'huffman trees') ----- decodeValueFrom: table "Decode the next value in the receiver using the given huffman table." | bits bitsNeeded tableIndex value | bitsNeeded := (table at: 1) bitShift: -24. "Initial bits needed" tableIndex := 2. "First real table" [bits := self getBits: bitsNeeded. "Get bits" value := table at: (tableIndex + bits). "Lookup entry in table" (value bitAnd: 16r3F000000) = 0] "Check if it is a non-leaf node" whileFalse:["Fetch sub table" tableIndex := value bitAnd: 16rFFFF. "Table offset in low 16 bit" bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" + bitsNeeded > MaxBits ifTrue:[^self error: 'Invalid huffman table entry' translated]]. - bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']]. ^value! Item was changed: ----- Method: JPEGReadStream>>getBits: (in category 'accessing') ----- getBits: requestedBits | value | requestedBits > bitsInBuffer ifTrue:[ self fillBuffer. requestedBits > bitsInBuffer ifTrue:[ + self error: 'not enough bits available to decode' translated]]. - self error: 'not enough bits available to decode']]. value := bitBuffer bitShift: (requestedBits - bitsInBuffer). bitBuffer := bitBuffer bitAnd: (1 bitShift: (bitsInBuffer - requestedBits)) -1. bitsInBuffer := bitsInBuffer - requestedBits. ^ value! Item was changed: ----- Method: JPEGReadWriter>>nextImageDitheredToDepth: (in category 'public access') ----- nextImageDitheredToDepth: depth | form xStep yStep x y bb | ditherMask := DitherMasks at: depth + ifAbsent: [self error: 'can only dither to display depths' translated]. - ifAbsent: [self error: 'can only dither to display depths']. residuals := WordArray new: 3. sosSeen := false. self parseFirstMarker. [sosSeen] whileFalse: [self parseNextMarker]. form := Form extent: (width @ height) depth: depth. bb := BitBlt toForm: form. bb sourceForm: mcuImageBuffer. bb colorMap: (mcuImageBuffer colormapIfNeededFor: form). bb sourceRect: mcuImageBuffer boundingBox. bb combinationRule: Form over. xStep := mcuWidth * DCTSize. yStep := mcuHeight * DCTSize. y := 0. 1 to: mcuRowsInScan do: [:row | x := 0. 1 to: mcusPerRow do: [:col | self decodeMCU. self idctMCU. self colorConvertMCU. bb destX: x; destY: y; copyBits. x := x + xStep]. y := y + yStep]. ^ form! Item was removed: - ----- Method: JPEGReadWriter>>notSupported: (in category 'error handling') ----- - notSupported: aString - - self error: aString , ' is not currently supported'! Item was changed: ----- Method: JPEGReadWriter>>parseAPPn (in category 'marker parsing') ----- parseAPPn | length buffer thumbnailLength markerStart | markerStart := self position. length := self nextWord. buffer := self next: 4. (buffer asString = 'JFIF') ifFalse: [ "Skip APPs that we're not interested in" stream next: length-6. ^self]. self next. majorVersion := self next. minorVersion := self next. densityUnit := self next. xDensity := self nextWord. yDensity := self nextWord. thumbnailLength := self next * self next * 3. length := length - (self position - markerStart). + length = thumbnailLength ifFalse: [self error: 'APP0 thumbnail length is incorrect.' translated]. - length = thumbnailLength ifFalse: [self error: 'APP0 thumbnail length is incorrect.']. self next: length! Item was changed: ----- Method: JPEGReadWriter>>parseDecoderRestartInterval (in category 'marker parsing') ----- parseDecoderRestartInterval | length | length := self nextWord. + length = 4 ifFalse: [self error: 'DRI length is incorrect.' translated]. - length = 4 ifFalse: [self error: 'DRI length incorrect']. restartInterval := self nextWord.! Item was changed: ----- Method: JPEGReadWriter>>parseFirstMarker (in category 'marker parsing') ----- parseFirstMarker | marker | + self next = 16rFF ifFalse: [self error: 'JFIF marker expected' translated]. - self next = 16rFF ifFalse: [self error: 'JFIF marker expected']. marker := self next. marker = 16rD9 ifTrue: [^self "halt: 'EOI encountered.'"]. + marker = 16rD8 ifFalse: [self error: 'SOI marker expected' translated]. - marker = 16rD8 ifFalse: [self error: 'SOI marker expected']. self parseStartOfInput. ! Item was changed: ----- Method: JPEGReadWriter>>parseHuffmanTable (in category 'marker parsing') ----- parseHuffmanTable | length markerStart index bits count huffVal isACTable hTable | markerStart := self position. length := self nextWord. [self position - markerStart >= length] whileFalse: [index := self next. isACTable := (index bitAnd: 16r10) ~= 0. index := (index bitAnd: 16r0F) + 1. index > HuffmanTableSize + ifTrue: [self error: ('image has more than {1} quantization tables' translated format: {HuffmanTableSize})]. - ifTrue: [self error: 'image has more than ', HuffmanTableSize printString, - ' quantization tables']. bits := self next: 16. count := bits sum. (count > 256 or: [(count > (length - (self position - markerStart)))]) + ifTrue: [self error: 'Huffman Table count is incorrect' translated]. - ifTrue: [self error: 'Huffman Table count is incorrect']. huffVal := self next: count. hTable := stream buildLookupTable: huffVal counts: bits. isACTable ifTrue: [self hACTable at: index put: hTable] ifFalse: [self hDCTable at: index put: hTable]].! Item was changed: ----- Method: JPEGReadWriter>>parseNextMarker (in category 'marker parsing') ----- parseNextMarker "Parse the next marker of the stream" | byte discardedBytes | discardedBytes := 0. [(byte := self next) = 16rFF] whileFalse: [discardedBytes := discardedBytes + 1]. [[(byte := self next) = 16rFF] whileTrue. byte = 16r00] whileTrue: [discardedBytes := discardedBytes + 2]. discardedBytes > 0 ifTrue: [self "notifyWithLabel: 'warning: extraneous data discarded'"]. self perform: (JFIFMarkerParser at: byte ifAbsent: [(self okToIgnoreMarker: byte) ifTrue: [#skipMarker] + ifFalse: [self error: ('marker {1} cannot be handled' translated format: {byte printStringHex})]])! - ifFalse: [self error: 'marker ', byte printStringHex , ' cannot be handled']])! Item was changed: ----- Method: JPEGReadWriter>>parseQuantizationTable (in category 'marker parsing') ----- parseQuantizationTable | length markerStart n prec value table | markerStart := self position. length := self nextWord. [self position - markerStart >= length] whileFalse: [value := self next. n := (value bitAnd: 16r0F) + 1. prec := (value >> 4) > 0. n > QuantizationTableSize + ifTrue: [self error: ('image has more than {1} quantization tables' translated format: {QuantizationTableSize})]. - ifTrue: [self error: 'image has more than ', - QuantizationTableSize printString, - ' quantization tables']. table := IntegerArray new: DCTSize2. 1 to: DCTSize2 do: [:i | value := (prec ifTrue: [self nextWord] ifFalse: [self next]). table at: (JPEGNaturalOrder at: i) put: value]. self useFloatingPoint ifTrue: [self scaleQuantizationTable: table]. self qTable at: n put: table]! Item was changed: ----- Method: JPEGReadWriter>>parseStartOfFile (in category 'marker parsing') ----- parseStartOfFile | length markerStart value n | markerStart := self position. length := self nextWord. dataPrecision := self next. dataPrecision = 8 + ifFalse: [self error: ('cannot handle {1}-bit components' translated format: {dataPrecision})]. - ifFalse: [self error: 'cannot handle ', dataPrecision printString, '-bit components']. height := self nextWord. width := self nextWord. n := self next. + (height = 0) | (width = 0) | (n = 0) ifTrue: [self error: 'empty image' translated]. - (height = 0) | (width = 0) | (n = 0) ifTrue: [self error: 'empty image']. (length - (self position - markerStart)) ~= (n * 3) + ifTrue: [self error: 'component length is incorrect' translated]. - ifTrue: [self error: 'component length is incorrect']. components := Array new: n. 1 to: components size do: [:i | components at: i put: (JPEGColorComponent new id: self next; "heightInBlocks: (((value := self next) >> 4) bitAnd: 16r0F); widthInBlocks: (value bitAnd: 16r0F);" widthInBlocks: (((value := self next) >> 4) bitAnd: 16r0F); heightInBlocks: (value bitAnd: 16r0F); qTableIndex: self next + 1)]! Item was changed: ----- Method: JPEGReadWriter>>parseStartOfScan (in category 'marker parsing') ----- parseStartOfScan | length n id value dcNum acNum comp | length := self nextWord. n := self next. + (length ~= (n*2 + 6)) | (n < 1) ifTrue: [self error: 'SOS length is incorrect' translated]. - (length ~= (n*2 + 6)) | (n < 1) ifTrue: [self error: 'SOS length is incorrect']. currentComponents := Array new: n. 1 to: n do: [:i | id := self next. value := self next. dcNum := (value >> 4) bitAnd: 16r0F. acNum := value bitAnd: 16r0F. comp := components detect: [:c | c id = id]. comp dcTableIndex: dcNum+1; acTableIndex: acNum+1. currentComponents at: i put: comp]. ss := self next. se := self next. value := self next. ah := (value >> 4) bitAnd: 16r0F. al := value bitAnd: 16r0F. self initialSOSSetup. self perScanSetup. sosSeen := true! Item was changed: ----- Method: JPEGReadWriter>>perScanSetup (in category 'marker parsing') ----- perScanSetup mcusPerRow := (width / (mcuWidth * DCTSize)) ceiling. mcuRowsInScan := (height / (mcuHeight * DCTSize)) ceiling. (currentComponents size = 3 or: [currentComponents size = 1]) + ifFalse: [self error: 'JPEG color space not recognized' translated]. - ifFalse: [self error: 'JPEG color space not recognized']. mcuMembership := OrderedCollection new. currentComponents withIndexDo: [:c :i | c priorDCValue: 0. mcuMembership addAll: ((1 to: c totalMcuBlocks) collect: [:b | i])]. mcuMembership := mcuMembership asArray. mcuSampleBuffer := (1 to: mcuMembership size) collect: [:i | IntegerArray new: DCTSize2]. currentComponents withIndexDo: [:c :i | c initializeSampleStreamBlocks: ((1 to: mcuMembership size) select: [:j | i = (mcuMembership at: j)] thenCollect: [:j | mcuSampleBuffer at: j])]. mcuImageBuffer := Form extent: (mcuWidth @ mcuHeight) * DCTSize depth: 32. restartsToGo := restartInterval.! Item was changed: ----- Method: JPEGReadWriter2>>compress:quality: (in category 'public access') ----- compress: aForm quality: quality "Encode the given Form and answer the compressed ByteArray. Quality goes from 0 (low) to 100 (high), where -1 means default. We can only compress: * 32-bit deep Forms * -32-bit deep Forms * 16-bit deep Forms * -16-bit deep Forms * GrayScale ColorForms (see #isGrayScale)" | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | aForm unhibernate. sourceForm := self supports8BitGrayscaleJPEGs ifTrue: [ (aForm depth = 32) | (aForm depth = 16) | (aForm isGrayScale) ifTrue: [aForm] ifFalse: [aForm asFormOfDepth: 32 ]] ifFalse: [ (aForm nativeDepth > 0) & ((aForm depth = 32) | ((aForm depth = 16) & (aForm width even))) ifTrue: [aForm] ifFalse: [aForm asFormOfDepth: 32 ]]. jpegCompressStruct := ByteArray new: self primJPEGCompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. buffer := ByteArray new: sourceForm width * sourceForm height + 1024. byteCount := self primJPEGWriteImage: jpegCompressStruct onByteArray: buffer form: sourceForm quality: quality progressiveJPEG: false errorMgr: jpegErrorMgr2Struct. + byteCount = 0 ifTrue: [self error: 'buffer too small for compressed data' translated]. - byteCount = 0 ifTrue: [self error: 'buffer too small for compressed data']. ^ buffer copyFrom: 1 to: byteCount ! Item was changed: ----- Method: JPEGReadWriter2>>nextPutImage:quality:progressiveJPEG: (in category 'public access') ----- nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag "Encode the given Form on my stream with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG. We can compress: * 32-bit deep Forms * -32-bit deep Forms * 16-bit deep * -16-bit deep * GrayScale ColorForms (see #isGrayScale)" | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | aForm unhibernate. sourceForm := self supports8BitGrayscaleJPEGs ifTrue: [ (aForm depth = 32) | (aForm depth = 16) | (aForm isGrayScale) ifTrue: [aForm] ifFalse: [aForm asFormOfDepth: 32 ]] ifFalse: [ (aForm nativeDepth > 0) & ((aForm depth = 32) | ((aForm depth = 16) & (aForm width even))) ifTrue: [aForm] ifFalse: [aForm asFormOfDepth: 32 ]]. jpegCompressStruct := ByteArray new: self primJPEGCompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. buffer := ByteArray new: sourceForm width * sourceForm height + 1024. "Try to write the image. Retry with a larger buffer if needed." [ byteCount := self primJPEGWriteImage: jpegCompressStruct onByteArray: buffer form: sourceForm quality: quality progressiveJPEG: progressiveFlag errorMgr: jpegErrorMgr2Struct. byteCount = 0 and: [ buffer size < (sourceForm width * sourceForm height * 3 + 1024) ] ] whileTrue: [ buffer := ByteArray new: buffer size * 2 ]. + byteCount = 0 ifTrue: [ self error: 'buffer too small for compressed data' translated ]. - byteCount = 0 ifTrue: [ self error: 'buffer too small for compressed data' ]. stream next: byteCount putAll: buffer startingAt: 1. self close. ! Item was changed: ----- Method: JPEGReadWriter2>>uncompress:into:doDithering: (in category 'public access') ----- uncompress: aByteArray into: aForm doDithering: ditherFlag "Uncompress an image from the given ByteArray into the given Form. Fails if the given Form has the wrong dimensions or depth. We can read RGB JPEGs into: * 32-bit Forms * -32-bit Forms * 16-bit Forms (with or without dithering!!) * -16-bit Forms (with or without dithering!!) We can read grayscale JPEGs into: * 32-bit Forms * -32-bit Forms * 16-bit Forms (with or without dithering!!) * -16-bit Forms (with or without dithering!!) * 8-bit grayScale ColorForms (see #isGrayScale) * -8-bit grayScale ColorForms (see #isGrayScale)" | jpegDecompressStruct jpegErrorMgr2Struct width height components | aForm unhibernate. jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. width := self primImageWidth: jpegDecompressStruct. height := self primImageHeight: jpegDecompressStruct. components := self primImageNumComponents: jpegDecompressStruct. ((aForm width = width) & (aForm height = height)) ifFalse: [ + ^ self error: 'form dimensions do not match' translated ]. - ^ self error: 'form dimensions do not match' ]. self supports8BitGrayscaleJPEGs ifTrue: [ components = 3 ifTrue: [ aForm depth = 8 + ifTrue: [ ^ self error: 'Cannot uncompress multi-channel JPEGs into 8-bit deep forms' translated ]]. - ifTrue: [ ^ self error: 'Cannot uncompress multi-channel JPEGs into 8-bit deep forms' ]]. components = 1 ifTrue: [ aForm depth = 8 ifTrue: [ aForm isGrayScale + ifFalse: [ ^ self error: 'Cannot uncompress single-channel JPEGs into 8-bit deep forms that are not grayscale' translated ]]]] - ifFalse: [ ^ self error: 'Cannot uncompress single-channel JPEGs into 8-bit deep forms that are not grayscale' ]]]] ifFalse: [ aForm nativeDepth < 0 + ifTrue: [ ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs into little-endian forms' translated ] - ifTrue: [ ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs into little-endian forms' ] ifFalse: [ aForm depth = 16 ifTrue: [ width odd + ifTrue: [ ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs with an odd width into 16-bit deep forms' translated ]]. - ifTrue: [ ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs with an odd width into 16-bit deep forms' ]]. aForm depth = 8 + ifTrue: [ ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs into 8-bit deep forms' translated ]]]. - ifTrue: [ ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs into 8-bit deep forms' ]]]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: aByteArray onForm: aForm doDithering: ditherFlag + errorMgr: jpegErrorMgr2Struct.! - errorMgr: jpegErrorMgr2Struct. - ! Item was changed: ----- Method: PCXReadWriter>>readPalette (in category 'private-decoding') ----- readPalette | r g b array | + self next = 12 ifFalse: [self error: 'no Color Palette!!' translated]. - self next = 12 ifFalse: [self error: 'no Color Palette!!']. array := Array new: (1 bitShift: bitsPerPixel). 1 to: array size do: [:i | r := self next. g := self next. b := self next. array at: i put: (Color r: r g: g b: b range: 255)]. ^ array. ! Item was changed: + ----- Method: PNGReadWriter class>>computeSwizzleMapForDepth: (in category 'class initialization') ----- - ----- Method: PNGReadWriter class>>computeSwizzleMapForDepth: (in category 'as yet unclassified') ----- computeSwizzleMapForDepth: depth "Answer a map that maps pixels in a word to their opposite location. Used for 'middle-endian' forms where the byte-order is different from the bit order (good joke, eh?)." | map swizzled | map := Bitmap new: 256. depth = 4 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 15) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 15) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. depth = 2 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 3) bitShift: 6). swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 3) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 3) bitShift: 2). swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 3) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. depth = 1 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 1) bitShift: 7). swizzled := swizzled bitOr: (((pix bitShift: -1) bitAnd: 1) bitShift: 6). swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 1) bitShift: 5). swizzled := swizzled bitOr: (((pix bitShift: -3) bitAnd: 1) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 1) bitShift: 3). swizzled := swizzled bitOr: (((pix bitShift: -5) bitAnd: 1) bitShift: 2). swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 1) bitShift: 1). swizzled := swizzled bitOr: (((pix bitShift: -7) bitAnd: 1) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. self error: 'Unrecognized depth'! Item was changed: + ----- Method: PNGReadWriter class>>debugging: (in category 'support') ----- - ----- Method: PNGReadWriter class>>debugging: (in category 'as yet unclassified') ----- debugging: aBoolean Debugging := aBoolean! Item was changed: + ----- Method: PNGReadWriter class>>initialize (in category 'class initialization') ----- - ----- Method: PNGReadWriter class>>initialize (in category 'as yet unclassified') ----- initialize " PNGReadWriter initialize " BPP := { #(1 2 4 8 16). #(0 0 0 0 0). #(0 0 0 24 48). #(1 2 4 8 0). #(0 0 0 16 32). #(0 0 0 0 0). #(0 0 0 32 64). #(0 0 0 0 0) }. BlockHeight := #(8 8 4 4 2 2 1). BlockWidth := #(8 4 4 2 2 1 1). StandardColors := Color indexedColors collect:[:aColor| Color r: (aColor red * 255) truncated / 255 g: (aColor green * 255) truncated / 255 b: (aColor blue * 255) truncated / 255. ]. StandardSwizzleMaps := Array new: 4. #(1 2 4) do:[:i| StandardSwizzleMaps at: i put: (self computeSwizzleMapForDepth: i)].! Item was removed: - ----- Method: PNGReadWriter class>>insertMorph:named:into: (in category 'as yet unclassified') ----- - insertMorph: aMorph named: aString into: aBook - - | newPage | - - aBook ifNil: [^self]. - newPage := aBook insertPageLabel: aString morphs: {aMorph}. - newPage color: Color lightYellow. - newPage extent: ( - newPage submorphs inject: 10@10 into: [ :ex :m | - m left: 10. - ex max: m width @ m bottom - ] - ) + (20@20). - ! Item was changed: ----- Method: PNGReadWriter>>nextImage (in category 'accessing') ----- nextImage bigEndian := Smalltalk isBigEndian. filtersSeen := Bag new. idatChunkStream := nil. transparentPixelValue := nil. unknownChunks := Set new. stream reset. stream binary. stream skip: 8. [stream atEnd] whileFalse: [self processNextChunk]. "Set up our form" palette ifNotNil: ["Dump the palette if it's the same as our standard palette" palette = (StandardColors copyFrom: 1 to: palette size) ifTrue: [palette := nil]]. (depth <= 8 and: [palette notNil]) ifTrue: [form := ColorForm extent: width @ height depth: depth. form colors: palette] ifFalse: [form := Form extent: width @ height depth: depth]. backColor ifNotNil: [form fillColor: backColor]. idatChunkStream + ifNil: [ self error: 'image data is missing' translated ] - ifNil: [ self error: 'image data is missing' ] ifNotNil: [ self processIDATChunk ]. unknownChunks isEmpty ifFalse: ["Transcript show: ' ',unknownChunks asSortedCollection asArray printString." ]. self debugging ifTrue: [Transcript cr; show: 'form = ' , form printString. Transcript cr; show: 'colorType = ' , colorType printString. Transcript cr; show: 'interlaceMethod = ' , interlaceMethod printString. Transcript cr; show: 'filters = ' , filtersSeen sortedCounts asArray printString]. ^form! Item was changed: ----- Method: PNGReadWriter>>processInterlaced (in category 'chunks') ----- processInterlaced | z startingCol colIncrement rowIncrement startingRow | startingCol := #(0 4 0 2 0 1 0 ). colIncrement := #(8 8 4 4 2 2 1 ). rowIncrement := #(8 8 8 4 4 2 2 ). startingRow := #(0 0 4 0 2 0 1 ). z := ZLibReadStream on: idatChunkStream originalContents from: 1 to: idatChunkStream position. 1 to: 7 do: [:pass | | cx sc bytesPerPass | (self doPass: pass) ifTrue: [cx := colIncrement at: pass. sc := startingCol at: pass. bytesPerPass := width - sc + cx - 1 // cx * bitsPerPixel + 7 // 8. prevScanline := ByteArray new: bytesPerPass. thisScanline := ByteArray new: bytesPerScanline. (startingRow at: pass) to: height - 1 by: (rowIncrement at: pass) do: [:y | | filter temp | filter := z next. filtersSeen add: filter. (filter isNil or: [(filter between: 0 and: 4) not]) ifTrue: [^ self]. thisScanline := z next: bytesPerPass into: thisScanline startingAt: 1. self filterScanline: filter count: bytesPerPass. self copyPixels: y at: sc by: cx. temp := prevScanline. prevScanline := thisScanline. thisScanline := temp. ] ] ]. + z atEnd ifFalse:[self error: 'Unexpected data' translated].! - z atEnd ifFalse:[self error:'Unexpected data'].! Item was changed: ----- Method: PNGReadWriter>>processNextChunk (in category 'chunks') ----- processNextChunk | length chunkType crc chunkCrc | length := self nextLong. chunkType := (self next: 4) asString. (chunk isNil or: [ chunk size ~= length ]) ifTrue: [ chunk := self next: length ] ifFalse: [ stream next: length into: chunk startingAt: 1 ]. chunkCrc := self nextLong bitXor: 16rFFFFFFFF. crc := self updateCrc: 16rFFFFFFFF from: 1 to: 4 in: chunkType. crc := self updateCrc: crc from: 1 to: length in: chunk. crc = chunkCrc ifFalse:[ + self error: ('PNGReadWriter crc error in chunk {1}' translated format: {chunkType}). - self error: 'PNGReadWriter crc error in chunk ', chunkType. ]. chunkType = 'IEND' ifTrue: [stream setToEnd. ^self "*should* be the last chunk"]. chunkType = 'sBIT' ifTrue: [^self processSBITChunk "could indicate unusual sample depth in original"]. chunkType = 'gAMA' ifTrue: [^self "indicates gamma correction value"]. chunkType = 'bKGD' ifTrue: [^self processBackgroundChunk]. chunkType = 'pHYs' ifTrue: [^self processPhysicalPixelChunk]. chunkType = 'tRNS' ifTrue: [^self processTransparencyChunk]. chunkType = 'IHDR' ifTrue: [^self processIHDRChunk]. chunkType = 'PLTE' ifTrue: [^self processPLTEChunk]. chunkType = 'IDAT' ifTrue: [ "---since the compressed data can span multiple chunks, stitch them all together first. later, if memory is an issue, we need to figure out how to do this on the fly---" idatChunkStream ifNil: [ idatChunkStream := WriteStream with: chunk copy ] ifNotNil: [ idatChunkStream nextPutAll: chunk ]. ^self ]. unknownChunks add: chunkType. ! Item was changed: ----- Method: PNGReadWriter>>processPLTEChunk (in category 'chunks') ----- processPLTEChunk | colorCount i | + colorCount := chunk size // 3. + self flag: #todo. "validate colorCount against depth" - colorCount := chunk size // 3. "TODO - validate colorCount against depth" palette := Array new: colorCount. 0 to: colorCount-1 do: [ :index | i := index * 3 + 1. palette at: index+1 put: (Color r: (chunk at: i)/255.0 g: (chunk at: i+1)/255.0 b: (chunk at: i+2)/255.0) ].! Item was changed: ----- Method: PNGReadWriter>>writeSBITChunkOn: (in category 'writing') ----- writeSBITChunkOn: aStream "Write the IDAT chunk" aStream nextPutAll: 'sBIT' asByteArray. + form depth = 16 ifFalse: [self notYetImplemented]. - form depth = 16 ifFalse:[self error: 'Unimplemented feature']. aStream nextPut: 5. aStream nextPut: 5. aStream nextPut: 5. aStream nextPut: 1.! Item was changed: ----- Method: PNMReadWriter>>nextImage (in category 'reading') ----- nextImage "read one image" | data p | first ifNil:[ first := false. data := stream contentsOfEntireFile. stream := (RWBinaryOrTextStream with: data) reset. ] ifNotNil:[ type < 4 ifTrue:[ + self error: 'Plain PBM, PGM or PPM have only one image' translated - self error:'Plain PBM, PGM or PPM have only one image' ]. ]. stream ascii. p := stream next. type := (stream next) asInteger - 48. (p = $P and:[type > 0 and:[type < 8]]) ifFalse:[ + self error: 'Not a PNM file' translated - self error:'Not a PNM file' ]. type = 7 ifTrue:[ self readHeaderPAM ] ifFalse: [ self readHeader ]. type caseOf: { [1] -> [^self readPlainBW]. [2] -> [^self readPlainGray]. [3] -> [^self readPlainRGB]. [4] -> [^self readBWreverse: false]. [5] -> [^self readGray]. [6] -> [^self readRGB]. [7] -> [ "PAM" (tupleType asUppercase) caseOf: { ['BLACKANDWHITE'] -> [^self readBWreverse: true]. ['GRAYSCALE'] -> [^self readGray]. ['RGB'] -> [^self readRGB]. + ['RGB_ALPHA'] -> [^self notYetImplemented]. + ['GRAYSCALE_ALPHA'] -> [^self notYetImplemented]. - ['RGB_ALPHA'] -> [^self error:'Not implemented']. - ['GRAYSCALE_ALPHA'] -> [^self error:'Not implemented']. } otherwise: [^self readData]. ] }! Item was changed: ----- Method: PNMReadWriter>>readGray (in category 'reading') ----- readGray "gray form, return ColorForm with gray ramp" | form poker | + maxValue > 255 ifTrue:[self error: ('Gray value > {1} bits not supported in Squeak' translated format: {8})]. - maxValue > 255 ifTrue:[self error:'Gray value > 8 bits not supported in Squeak']. stream binary. form := ColorForm extent: cols@rows depth: depth. form colors: nil. poker := BitBlt bitPokerToForm: form. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | |val| val := stream next. poker pixelAt: x@y put: val. ] ]. "a better way is using a gamma corrected palette" form colors: ((0 to: 255) collect:[:c| c > maxValue ifTrue:[Color white] ifFalse:[Color gray: (c/maxValue) asFloat]]). form colors at: 1 put: (Color black). ^form ! Item was changed: ----- Method: PNMReadWriter>>readHeader (in category 'reading') ----- readHeader "read header for pbm, pgm or ppm" | tokens aux d c | tokens := OrderedCollection new. aux := self getTokenPbm: tokens. cols := aux at: 1. tokens := aux at: 2. aux := self getTokenPbm: tokens. rows := aux at: 1. tokens := aux at: 2. (type = 1 or:[type = 4]) ifTrue:[ maxValue := 1 ] ifFalse: [ aux := self getTokenPbm: tokens. maxValue := aux at: 1. tokens := aux at: 2. ]. d := {1 . 2 . 4 . 8 . 16 . 32}. c := {2 . 4 . 16 . 256 . 32768 . 16777216}. (type = 3 or:[type = 6]) ifTrue: [ maxValue >= 65536 ifTrue:[ + self error: ('Pixmap > {1} bits not supported in PPM' translated format: {48}) - self error:'Pixmap > 48 bits not supported in PPM' ]. maxValue >= 256 ifTrue:[ + self error: ('Pixmap > {1} bits are not supported in Squeak' translated format: {32}) - self error:'Pixmap > 32 bits are not supported in Squeak' ]. maxValue < 32 ifTrue:[depth := 16] ifFalse:[depth := 32]. ] ifFalse: [ depth := nil. 1 to: c size do:[:i| ((c at: i) > maxValue and:[depth = nil]) ifTrue:[depth:=d at: i]]. ]. Transcript cr; show: 'PBM file class ', type asString, ' size ', cols asString, ' x ', rows asString, ' maxValue =', maxValue asString, ' depth=', depth asString. ! Item was changed: ----- Method: PNMReadWriter>>readPlainBW (in category 'reading') ----- readPlainBW "plain BW" | val form poker | form := Form extent: cols@rows depth: depth. poker := BitBlt bitPokerToForm: form. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | [val := stream next. (val = $0 or:[val = $1])] whileFalse:[ + val ifNil: [self error: 'End of file reading PBM' translated]. - val ifNil:[self error:'End of file reading PBM']. ]. poker pixelAt: x@y put: (val asInteger). ] ]. ^form ! Item was changed: ----- Method: PNMReadWriter>>readPlainRGB (in category 'reading') ----- readPlainRGB "RGB form, use 32 bits" | val form poker tokens aux | + maxValue > 255 ifTrue:[self error: ('RGB value > {1} bits not supported in Squeak' translated format: {32})]. - maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not supported in Squeak']. form := Form extent: cols@rows depth: 32. poker := BitBlt bitPokerToForm: form. tokens := OrderedCollection new. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | | r g b| aux := self getTokenPbm: tokens. r := aux at: 1. tokens := aux at: 2. aux := self getTokenPbm: tokens. g := aux at: 1. tokens := aux at: 2. aux := self getTokenPbm: tokens. b := aux at: 1. tokens := aux at: 2. val := self r: r g: g b: b for: depth. poker pixelAt: x@y put: val. ] ]. ^form ! Item was changed: ----- Method: PNMReadWriter>>readRGB (in category 'reading') ----- readRGB "RGB form, use 16/32 bits" | val form poker sample shift | + maxValue > 255 ifTrue:[self error: ('RGB value > {1} bits not supported in Squeak' translated format: {32})]. - maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not supported in Squeak']. stream binary. form := Form extent: cols@rows depth: depth. poker := BitBlt bitPokerToForm: form. depth = 32 ifTrue:[shift := 8] ifFalse:[shift := 5]. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | val := 16rFF. "no transparency" 1 to: 3 do: [:i | sample := stream next. val := val << shift + sample. ]. poker pixelAt: x@y put: val. ] ]. ^form ! Item was changed: ----- Method: StrikeFont class>>generateDejaVuMethods: (in category 'font creation') ----- generateDejaVuMethods: directory "StrikeFont generateDejaVuMethods: 'DejaVu'." | dir formTemplate dataTemplate methodCategory | methodCategory := #'dejaVu font data'. formTemplate := '{1} <generated> " Form data for {2}. Generated with StrikeFont generateDejaVuMethods: ''{3}''" ^Form fromBinaryStream: ( ''{4}'' ) base64Decoded asByteArray readStream '. dataTemplate := '{1} <generated> " Font meta data for {2}. Generated with StrikeFont generateDejaVuMethods: ''{3}''" ^ #({4}) '. dir := FileDirectory default / directory. #('*.txt' 'Data' '*.png' 'Form') pairsDo: [:match :suffix | (dir fileNamesMatching: match) do: [:local | | selector source stringContent| " .txt and .png have both length 4" selector := (local allButLast: 4) asLegalSelector, suffix. stringContent := dir readOnlyFileNamed: local do: [:stream | suffix = 'Data' ifTrue: [stream contentsOfEntireFile] ifFalse: [(stream binary; contentsOfEntireFile) base64Encoded]]. source := (suffix = 'Data' ifTrue: [dataTemplate] ifFalse: [formTemplate]) format: {selector . (local allButLast: 4) . directory . stringContent }. self class compile: source classified: methodCategory] + displayingProgress: [:local | 'Generating {1}' translated format: {local}]].! - displayingProgress: [:local | 'Generating ', local]].!

1 0

The Trunk: EToys-ct.455.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-ct.455.mcz ==================== Summary ==================== Name: EToys-ct.455 Author: ct Time: 3 January 2022, 7:42:29.166703 pm UUID: 9495aecb-a9c1-884e-bfc7-67c3deaf0691 Ancestors: EToys-mt.454 Improves multilingual support and performs recategorizations for Squeakland-Sound and FileStream extensions. =============== Diff against EToys-mt.454 =============== Item was changed: + ----- Method: CodecDemoMorph>>codecClassName: (in category 'accessing') ----- - ----- Method: CodecDemoMorph>>codecClassName: (in category 'as yet unclassified') ----- codecClassName: aStringOrSymbol | label | codecClassName := aStringOrSymbol asSymbol. self removeAllMorphs. label := StringMorph contents: aStringOrSymbol. label position: self position + (5@5). self addMorph: label. label lock: true. self extent: label extent + (10@10). ! Item was changed: + ----- Method: CodecDemoMorph>>selectCodec (in category 'accessing') ----- - ----- Method: CodecDemoMorph>>selectCodec (in category 'as yet unclassified') ----- selectCodec | aMenu codecs newCodec | + aMenu := CustomMenu new title: 'Codec:' translated. - aMenu := CustomMenu new title: 'Codec:'. codecs := SoundCodec allSubclasses collect: [:c | c name] as: OrderedCollection. codecs add: 'None'. codecs sort do:[:cName | aMenu add: cName action: cName]. newCodec := aMenu startUp ifNil: [^ self]. self codecClassName: newCodec. ! Item was changed: + ----- Method: MIDIPianoKeyboardMorph>>closeMIDIPort (in category 'accessing') ----- - ----- Method: MIDIPianoKeyboardMorph>>closeMIDIPort (in category 'as yet unclassified') ----- closeMIDIPort midiPort := nil. ! Item was changed: + ----- Method: MIDIPianoKeyboardMorph>>makeMIDIController: (in category 'accessing') ----- - ----- Method: MIDIPianoKeyboardMorph>>makeMIDIController: (in category 'as yet unclassified') ----- makeMIDIController: evt self world activeHand attachMorph: (MIDIControllerMorph new midiPort: midiPort). ! Item was changed: + ----- Method: MIDIPianoKeyboardMorph>>openMIDIPort (in category 'accessing') ----- - ----- Method: MIDIPianoKeyboardMorph>>openMIDIPort (in category 'as yet unclassified') ----- openMIDIPort | portNum | portNum := SimpleMIDIPort outputPortNumFromUser. portNum ifNil: [^ self]. midiPort := SimpleMIDIPort openOnPortNumber: portNum. ! Item was changed: + ----- Method: MIDIPianoKeyboardMorph>>turnOffNote (in category 'accessing') ----- - ----- Method: MIDIPianoKeyboardMorph>>turnOffNote (in category 'as yet unclassified') ----- turnOffNote midiPort notNil & soundPlaying notNil ifTrue: [ soundPlaying isInteger ifTrue: [ midiPort midiCmd: 16r90 channel: channel byte: soundPlaying byte: 0]]. soundPlaying := nil. ! Item was changed: + ----- Method: MIDIPianoKeyboardMorph>>turnOnNote: (in category 'accessing') ----- - ----- Method: MIDIPianoKeyboardMorph>>turnOnNote: (in category 'as yet unclassified') ----- turnOnNote: midiKey midiPort midiCmd: 16r90 channel: channel byte: midiKey byte: velocity. soundPlaying := midiKey. ! Item was changed: + ----- Method: MidiInputMorph>>addChannel (in category 'actions') ----- - ----- Method: MidiInputMorph>>addChannel (in category 'as yet unclassified') ----- addChannel "Add a set of controls for another channel. Prompt the user for the channel number." | menu existingChannels newChannel | menu := CustomMenu new. existingChannels := Set new. 1 to: 16 do: [:ch | (instrumentSelector at: ch) ifNotNil: [existingChannels add: ch]]. 1 to: 16 do: [:ch | (existingChannels includes: ch) ifFalse: [ menu add: ch printString action: ch]]. newChannel := menu startUp. newChannel ifNotNil: [self addChannelControlsFor: newChannel]. ! Item was changed: + ----- Method: MidiInputMorph>>addChannelControlsFor: (in category 'accessing') ----- - ----- Method: MidiInputMorph>>addChannelControlsFor: (in category 'as yet unclassified') ----- addChannelControlsFor: channelIndex | r divider col | r := self makeRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. r addMorphBack: (self channelNumAndMuteButtonFor: channelIndex). r addMorphBack: (Morph new extent: 10@5; color: color). "spacer" r addMorphBack: (self panAndVolControlsFor: channelIndex). divider := AlignmentMorph new extent: 10@1; layoutInset: 0; borderStyle: (BorderStyle raised width: 1); color: color; hResizing: #spaceFill; vResizing: #rigid. col := self lastSubmorph. col addMorphBack: divider. col addMorphBack: r. ! Item was changed: + ----- Method: MidiInputMorph>>atChannel:from:selectInstrument: (in category 'accessing') ----- - ----- Method: MidiInputMorph>>atChannel:from:selectInstrument: (in category 'as yet unclassified') ----- atChannel: channelIndex from: aPopUpChoice selectInstrument: selection | oldSnd name snd instSelector | oldSnd := midiSynth instrumentForChannel: channelIndex. (selection beginsWith: 'edit ') ifTrue: [name := selection copyFrom: 6 to: selection size. aPopUpChoice contentsClipped: name. (oldSnd isKindOf: FMSound) | (oldSnd isKindOf: LoopedSampledSound) ifTrue: [EnvelopeEditorMorph openOn: oldSnd title: name]. (oldSnd isKindOf: SampledInstrument) ifTrue: [EnvelopeEditorMorph openOn: oldSnd allNotes first title: name]. ^self]. snd := nil. 1 to: instrumentSelector size do: [:i | (channelIndex ~= i and: [(instSelector := instrumentSelector at: i) notNil and: [selection = instSelector contents]]) ifTrue: [snd := midiSynth instrumentForChannel: i]]. "use existing instrument prototype" snd ifNil: [snd := (selection = 'clink' ifTrue: [(SampledSound samples: SampledSound coffeeCupClink samplingRate: 11025)] ifFalse: [(AbstractSound soundNamed: selection) ])copy ]. midiSynth instrumentForChannel: channelIndex put: snd. (instrumentSelector at: channelIndex) contentsClipped: selection! Item was changed: + ----- Method: MidiInputMorph>>channelNumAndMuteButtonFor: (in category 'accessing') ----- - ----- Method: MidiInputMorph>>channelNumAndMuteButtonFor: (in category 'as yet unclassified') ----- channelNumAndMuteButtonFor: channelIndex | muteButton instSelector r | muteButton := SimpleSwitchMorph new onColor: (Color r: 1.0 g: 0.6 b: 0.6); offColor: color; color: color; + label: 'Mute' translated; - label: 'Mute'; target: midiSynth; actionSelector: #mutedForChannel:put:; arguments: (Array with: channelIndex). instSelector := PopUpChoiceMorph new extent: 95@14; contentsClipped: 'oboe1'; target: self; actionSelector: #atChannel:from:selectInstrument:; getItemsSelector: #instrumentChoicesForChannel:; getItemsArgs: (Array with: channelIndex). instSelector arguments: (Array with: channelIndex with: instSelector). instrumentSelector at: channelIndex put: instSelector. r := self makeRow hResizing: #rigid; vResizing: #spaceFill; extent: 70@10. r addMorphBack: (StringMorph contents: channelIndex printString font: (TextStyle default fontOfSize: 24)). channelIndex < 10 ifTrue: [r addMorphBack: (Morph new color: color; extent: 19@8)] "spacer" ifFalse: [r addMorphBack: (Morph new color: color; extent: 8@8)]. "spacer" r addMorphBack: instSelector. r addMorphBack: (AlignmentMorph newRow color: color). "spacer" r addMorphBack: muteButton. + ^ r! - ^ r - ! Item was changed: + ----- Method: MidiInputMorph>>closeMIDIPort (in category 'accessing') ----- - ----- Method: MidiInputMorph>>closeMIDIPort (in category 'as yet unclassified') ----- closeMIDIPort midiSynth isOn ifTrue: [midiSynth stopMIDITracking]. midiSynth closeMIDIPort. ! Item was changed: + ----- Method: MidiInputMorph>>disableReverb: (in category 'accessing') ----- - ----- Method: MidiInputMorph>>disableReverb: (in category 'as yet unclassified') ----- disableReverb: aBoolean Preferences setPreference: #soundReverb toValue: aBoolean not ! Item was changed: + ----- Method: MidiInputMorph>>instrumentChoicesForChannel: (in category 'accessing') ----- - ----- Method: MidiInputMorph>>instrumentChoicesForChannel: (in category 'as yet unclassified') ----- instrumentChoicesForChannel: channelIndex | names inst | names := AbstractSound soundNames asOrderedCollection. names := names collect: [:n | inst := AbstractSound soundNamed: n. (inst isKindOf: UnloadedSound) ifTrue: [n, '(out)'] ifFalse: [n]]. names add: 'clink'. names add: 'edit ', (instrumentSelector at: channelIndex) contents. ^ names asArray ! Item was changed: + ----- Method: MidiInputMorph>>invokeMenu (in category 'actions') ----- - ----- Method: MidiInputMorph>>invokeMenu (in category 'as yet unclassified') ----- invokeMenu "Invoke a menu of additonal commands." | aMenu | aMenu := CustomMenu new. aMenu add: 'add channel' translated action: #addChannel. aMenu add: 'reload instruments' translated target: AbstractSound selector: #updateScorePlayers. midiSynth isOn ifFalse: [ aMenu add: 'set MIDI port' translated action: #setMIDIPort. midiSynth midiPort ifNotNil: [aMenu add: 'close MIDI port' translated action: #closeMIDIPort]]. aMenu invokeOn: self defaultSelection: nil. ! Item was changed: + ----- Method: MidiInputMorph>>makeControls (in category 'initialization') ----- - ----- Method: MidiInputMorph>>makeControls (in category 'as yet unclassified') ----- makeControls | bb r reverbSwitch onOffSwitch | bb := SimpleButtonMorph new target: self; borderStyle: (BorderStyle raised width: 2); color: color. r := AlignmentMorph newRow. r color: bb color; borderWidth: 0; layoutInset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r addMorphBack: ( bb label: '<>'; actWhen: #buttonDown; actionSelector: #invokeMenu). onOffSwitch := SimpleSwitchMorph new offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2; + label: 'On' translated; - label: 'On'; actionSelector: #toggleOnOff; target: self; setSwitchState: false. r addMorphBack: onOffSwitch. reverbSwitch := SimpleSwitchMorph new offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2; + label: 'Reverb Disable' translated; - label: 'Reverb Disable'; actionSelector: #disableReverb:; target: self; setSwitchState: SoundPlayer isReverbOn not. r addMorphBack: reverbSwitch. + ^ r! - ^ r - ! Item was changed: + ----- Method: MidiInputMorph>>makeRow (in category 'initialization') ----- - ----- Method: MidiInputMorph>>makeRow (in category 'as yet unclassified') ----- makeRow ^ AlignmentMorph newRow color: color; layoutInset: 0; wrapCentering: #center; cellPositioning: #leftCenter; hResizing: #spaceFill; vResizing: #shrinkWrap ! Item was changed: + ----- Method: MidiInputMorph>>panAndVolControlsFor: (in category 'initialization') ----- - ----- Method: MidiInputMorph>>panAndVolControlsFor: (in category 'as yet unclassified') ----- panAndVolControlsFor: channelIndex | volSlider panSlider c r middleLine | volSlider := SimpleSliderMorph new color: color; extent: 101@2; target: midiSynth; arguments: (Array with: channelIndex); actionSelector: #volumeForChannel:put:; minVal: 0.0; maxVal: 1.0; adjustToValue: (midiSynth volumeForChannel: channelIndex). panSlider := SimpleSliderMorph new color: color; extent: 101@2; target: midiSynth; arguments: (Array with: channelIndex); actionSelector: #panForChannel:put:; minVal: 0.0; maxVal: 1.0; adjustToValue: (midiSynth panForChannel: channelIndex). c := AlignmentMorph newColumn color: color; layoutInset: 0; wrapCentering: #center; cellPositioning: #topCenter; hResizing: #spaceFill; vResizing: #shrinkWrap. middleLine := Morph new "center indicator for pan slider" color: (Color r: 0.4 g: 0.4 b: 0.4); extent: 1@(panSlider height - 4); position: panSlider center x@(panSlider top + 2). panSlider addMorphBack: middleLine. r := self makeRow. r addMorphBack: (StringMorph contents: '0'). r addMorphBack: volSlider. r addMorphBack: (StringMorph contents: '10'). c addMorphBack: r. r := self makeRow. r addMorphBack: (StringMorph contents: 'L'). r addMorphBack: panSlider. r addMorphBack: (StringMorph contents: 'R'). c addMorphBack: r. ^ c ! Item was changed: + ----- Method: MidiInputMorph>>setMIDIPort (in category 'accessing') ----- - ----- Method: MidiInputMorph>>setMIDIPort (in category 'as yet unclassified') ----- setMIDIPort | portNum | portNum := SimpleMIDIPort outputPortNumFromUser. portNum ifNil: [^ self]. midiPortNumber := portNum. ! Item was changed: + ----- Method: MidiInputMorph>>toggleOnOff (in category 'accessing') ----- - ----- Method: MidiInputMorph>>toggleOnOff (in category 'as yet unclassified') ----- toggleOnOff midiSynth isOn ifTrue: [ midiSynth stopMIDITracking] ifFalse: [ midiPortNumber ifNil: [self setMIDIPort]. midiPortNumber ifNil: [midiPortNumber := 0]. midiSynth midiPort: (SimpleMIDIPort openOnPortNumber: midiPortNumber). midiSynth startMIDITracking]. ! Item was changed: + ----- Method: MidiInputMorph>>updateInstrumentsFromLibraryExcept: (in category 'fileIn/out') ----- - ----- Method: MidiInputMorph>>updateInstrumentsFromLibraryExcept: (in category 'as yet unclassified') ----- updateInstrumentsFromLibraryExcept: soundsBeingEdited "The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype." "soundsBeingEdited is a collection of sounds being edited (by an EnvelopeEditor). If any of my instruments share one of these, then they will be left alone so as not to disturb that dynamic linkage." | unloadPostfix myInstruments name displaysAsUnloaded isUnloaded | unloadPostfix := '(out)'. myInstruments := Dictionary new. 1 to: instrumentSelector size do: [:i | name := (instrumentSelector at: i) contents. displaysAsUnloaded := name endsWith: unloadPostfix. displaysAsUnloaded ifTrue: [ name := name copyFrom: 1 to: name size - unloadPostfix size]. (myInstruments includesKey: name) ifFalse: [ myInstruments at: name put: (name = 'clink' ifTrue: [ (SampledSound samples: SampledSound coffeeCupClink samplingRate: 11025) copy] ifFalse: [ (AbstractSound soundNamed: name ifAbsent: [ (instrumentSelector at: i) contentsClipped: 'default'. FMSound default]) copy])]. (soundsBeingEdited includes: (midiSynth instrumentForChannel: i)) ifFalse: ["Do not update any instrument that is currently being edited" midiSynth instrumentForChannel: i put: (myInstruments at: name)]. "update loaded/unloaded status in instrumentSelector if necessary" isUnloaded := (myInstruments at: name) isKindOf: UnloadedSound. (displaysAsUnloaded and: [isUnloaded not]) ifTrue: [(instrumentSelector at: i) contentsClipped: name]. (displaysAsUnloaded not and: [isUnloaded]) ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]]. ! Item was changed: ----- Method: OggDriver class>>example3 (in category 'examples') ----- example3 "OggDriver example3" "Primitive metatada test: Reading Ogg Vorbis and output to Transcript." | f compressed driver ogg vendor comment commentSize fileName rate channels | fileName := 'majorChord.ogg'. f := FileDirectory default readOnlyFileNamed: fileName. [f binary. compressed := f contents] ensure: [f close]. driver := self new. ogg := driver primitiveOpen: (SqVorbis bitOr: SqOggDecode). driver primitiveWrite: ogg buffer: compressed size: compressed size. self assert: (driver primitiveGetState: ogg) == SqOggRunning. rate := driver primitiveGetRate: ogg. channels := driver primitiveGetChannels: ogg. Transcript cr; + show: ('Bitstream is {1} channel, {2} Hz' translated format: {rate. channels}). - show: ('Bitstream is {1} channel, {2} Hz' format: {rate. channels}). vendor := String new: 1024. driver primitiveGetVendor: ogg buffer: vendor size: 1024. Transcript cr; show: 'Encoded by:' , (vendor readStream upTo: (Character value: 0)). commentSize := driver primitiveGetCommentSize: ogg. comment := String new: commentSize. driver primitiveGetComment: ogg buffer: comment size: commentSize. Transcript cr; show: comment. driver primitiveClose: ogg! Item was changed: ----- Method: OggDriver class>>services (in category 'class initialization') ----- services | service | service := SimpleServiceEntry + provider: self + label: 'sound file' translatedNoop + selector: #playFileNamed: + description: 'play the sound' translatedNoop + buttonLabel: 'play' translatedNoop. - provider: self - label: 'sound file' - selector: #playFileNamed: - description: 'play the sound' - buttonLabel: 'play'. ^ Array with: service! Item was changed: ----- Method: OggDriver>>decodeCompressedData: (in category 'compress/decompress') ----- decodeCompressedData: aByteArray "Answer decompressed SoundBuffer, or nil if it needs more data" | decoded size result | state ifNil: [state := self startDecoder]. result := self primitiveWrite: state buffer: aByteArray size: aByteArray size. result = SqOggSuccess + ifFalse: [self error: 'Compressed data is corrupt' translated]. - ifFalse: [self error: 'Compressed data is corrupt']. size := self primitiveReadSize: state. size = 0 ifTrue: [^ nil]. decoded := SoundBuffer newMonoSampleCount: size // 2. self primitiveRead: state buffer: decoded size: size. self hasHeader ifFalse: [self headerComplete]. ^ decoded! Item was changed: ----- Method: OggSoundData>>asSound (in category 'asSound') ----- asSound | codecClass theDecoder | self isHeader ifTrue: [codecClass := Smalltalk at: codecName + ifAbsent: [^ self error: 'The codec for decompressing this sound is not available' translated]. - ifAbsent: [^ self error: 'The codec for decompressing this sound is not available']. codecClass isAvailable + ifFalse: [^ self error: 'The codec for decompressing this sound is not available' translated]. - ifFalse: [^ self error: 'The codec for decompressing this sound is not available']. decoder ifNotNil: [decoder release]. theDecoder := decoder := codecClass new] ifFalse: [theDecoder := header decoder]. ^ theDecoder soundFromCompressedData: channels first! Item was changed: ----- Method: OggSoundData>>decoder (in category 'accessing') ----- decoder self isHeader ifTrue: [^ decoder]. + self error: 'Only header has a decoder.' translated.! - self error: 'Only header has a decoder.'! Item was changed: + ----- Method: RecordingControls class>>additionsToViewerCategories (in category 'scripting') ----- - ----- Method: RecordingControls class>>additionsToViewerCategories (in category 'as yet unclassified') ----- additionsToViewerCategories "Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #((#'sound recorder' ((command recordButtonHit 'start recording') (command stopButtonHit 'stop recording or playback') (command playButtonHit 'play recording') )))! Item was changed: ----- Method: RecordingControls>>makeSoundMorph (in category 'private') ----- makeSoundMorph "Hand the user an anonymous-sound object representing the receiver's sound." | m aName | recorder verifyExistenceOfRecordedSound ifFalse: [^ self]. recorder pause. recordingSaved := true. m := AnonymousSoundMorph new. + m sound: recorder recordedSound interimName: (aName := 'Unnamed Sound' translated). - m sound: recorder recordedSound interimName: (aName := 'Unnamed Sound'). m setNameTo: aName. self currentHand attachMorph: m.! Item was changed: + ----- Method: SoundDemoMorph>>makeControls (in category 'private') ----- - ----- Method: SoundDemoMorph>>makeControls (in category 'as yet unclassified') ----- makeControls | bb r cc | cc := Color black. r := AlignmentMorph newRow. r color: cc; borderWidth: 0; layoutInset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. bb := SimpleButtonMorph new target: self; borderColor: cc. r addMorphBack: (bb label: 'V1'; actionSelector: #playV1). bb := SimpleButtonMorph new target: self; borderColor: cc. r addMorphBack: (bb label: 'V2'; actionSelector: #playV2). bb := SimpleButtonMorph new target: self; borderColor: cc. r addMorphBack: (bb label: 'V3'; actionSelector: #playV3). bb := SimpleButtonMorph new target: self; borderColor: cc. r addMorphBack: (bb label: 'All'; actionSelector: #playAll). bb := SimpleButtonMorph new target: self; borderColor: cc. r addMorphBack: (bb label: 'Stop'; actionSelector: #stopSound). ^ r ! Item was changed: + ----- Method: SoundDemoMorph>>playAll (in category 'private') ----- - ----- Method: SoundDemoMorph>>playAll (in category 'as yet unclassified') ----- playAll | snd | soundColumn submorphs isEmpty ifTrue: [^ self]. self setTimbreFromTile: soundColumn submorphs first. snd := SampledSound bachFugueVoice1On: SampledSound new. soundColumn submorphs size >= 2 ifTrue: [""self setTimbreFromTile: soundColumn submorphs second. snd := snd + (AbstractSound bachFugueVoice2On: SampledSound new)]. soundColumn submorphs size >= 3 ifTrue: [""self setTimbreFromTile: soundColumn submorphs third. snd := snd + (AbstractSound bachFugueVoice3On: SampledSound new)]. snd play! Item was changed: + ----- Method: SoundDemoMorph>>playV1 (in category 'private') ----- - ----- Method: SoundDemoMorph>>playV1 (in category 'as yet unclassified') ----- playV1 soundColumn submorphs isEmpty ifTrue: [^ self]. self setTimbreFromTile: (soundColumn submorphs first). (SampledSound bachFugueVoice1On: SampledSound new) play! Item was changed: + ----- Method: SoundDemoMorph>>playV2 (in category 'private') ----- - ----- Method: SoundDemoMorph>>playV2 (in category 'as yet unclassified') ----- playV2 soundColumn submorphs size < 2 ifTrue: [^ self]. self setTimbreFromTile: (soundColumn submorphs second). (SampledSound bachFugueVoice2On: SampledSound new) playSilentlyUntil: 4.8; resumePlaying! Item was changed: + ----- Method: SoundDemoMorph>>playV3 (in category 'private') ----- - ----- Method: SoundDemoMorph>>playV3 (in category 'as yet unclassified') ----- playV3 soundColumn submorphs size < 3 ifTrue: [^ self]. self setTimbreFromTile: (soundColumn submorphs third). (AbstractSound bachFugueVoice3On: SampledSound new) playSilentlyUntil: 14.4; resumePlaying! Item was changed: + ----- Method: SoundDemoMorph>>setTimbreFromTile: (in category 'private') ----- - ----- Method: SoundDemoMorph>>setTimbreFromTile: (in category 'as yet unclassified') ----- setTimbreFromTile: aSoundTile SampledSound defaultSampleTable: aSoundTile sound samples. SampledSound nominalSamplePitch: 400. ! Item was changed: + ----- Method: SoundDemoMorph>>stopSound (in category 'private') ----- - ----- Method: SoundDemoMorph>>stopSound (in category 'as yet unclassified') ----- stopSound SoundPlayer shutDown. ! Item was changed: + ----- Method: SoundMorph>>buildImage (in category 'accessing') ----- - ----- Method: SoundMorph>>buildImage (in category 'as yet unclassified') ----- buildImage | scale env h imageColor | owner ifNil: [scale := 128@128] "Default is 128 pix/second, 128 pix fullscale" ifNotNil: [scale := owner soundScale]. env := sound volumeEnvelopeScaledTo: scale. self image: (ColorForm extent: env size @ env max). 1 to: image width do: [:x | h := env at: x. image fillBlack: ((x-1)@(image height-h//2) extent: 1@h)]. imageColor := #(black red orange green blue) atPin: (sound pitch / 110.0) rounded highBit. image colors: (Array with: Color transparent with: (Color perform: imageColor)). ! Item was changed: + ----- Method: SoundMorph>>reset (in category 'accessing') ----- - ----- Method: SoundMorph>>reset (in category 'as yet unclassified') ----- reset sound reset! Item was changed: + ----- Method: SoundMorph>>sound (in category 'accessing') ----- - ----- Method: SoundMorph>>sound (in category 'as yet unclassified') ----- sound ^ sound! Item was changed: + ----- Method: SoundMorph>>sound: (in category 'accessing') ----- - ----- Method: SoundMorph>>sound: (in category 'as yet unclassified') ----- sound: aSound sound := aSound copy. sound reset. self buildImage! Item was changed: + ----- Method: SoundSequencerMorph>>makeControlPanel (in category 'initialization') ----- - ----- Method: SoundSequencerMorph>>makeControlPanel (in category 'as yet unclassified') ----- makeControlPanel | bb cc | cc := Color black. bb := SimpleButtonMorph new target: self; borderColor: cc. controlPanel := AlignmentMorph newRow. bb := SimpleButtonMorph new target: self; borderColor: cc. controlPanel color: bb color; borderWidth: 0; layoutInset: 0. controlPanel hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. bb := SimpleButtonMorph new target: self; borderColor: cc. + controlPanel addMorphBack: (bb label: 'reset' translated; actionSelector: #reset). - controlPanel addMorphBack: (bb label: 'reset'; actionSelector: #reset). bb := SimpleButtonMorph new target: self; borderColor: cc. + controlPanel addMorphBack: (bb label: 'stop' translated; actionSelector: #stop). - controlPanel addMorphBack: (bb label: 'stop'; actionSelector: #stop). bb := SimpleButtonMorph new target: self; borderColor: cc. + controlPanel addMorphBack: (bb label: 'play' translated; actionSelector: #play). - controlPanel addMorphBack: (bb label: 'play'; actionSelector: #play). ! Item was changed: + ----- Method: SoundSequencerMorph>>play (in category 'accessing') ----- - ----- Method: SoundSequencerMorph>>play (in category 'as yet unclassified') ----- play self submorphsDo: [:m | m == controlPanel ifFalse: [m play]]! Item was changed: + ----- Method: SoundSequencerMorph>>reset (in category 'accessing') ----- - ----- Method: SoundSequencerMorph>>reset (in category 'as yet unclassified') ----- reset self submorphsDo: [:m | m == controlPanel ifFalse: [m reset]]! Item was changed: + ----- Method: SpectrumAnalyzerMorph class>>descriptionForPartsBin (in category 'parts bin') ----- - ----- Method: SpectrumAnalyzerMorph class>>descriptionForPartsBin (in category 'as yet unclassified') ----- descriptionForPartsBin ^ self partName: 'Spectrum Analyzer' translatedNoop categories: {'Multimedia' translatedNoop} documentation: 'A device for analyzing sound input' translatedNoop ! Item was changed: ----- Method: StandardFileStream class>>fileDoesNotExistUserHandling: (in category '*Etoys-Squeakland-error handling') ----- fileDoesNotExistUserHandling: fullFileName | selection newName | selection := (PopUpMenu labels: 'create a new file choose another name cancel' translated) startUpWithCaption: ('{1} does not exist.' translated format: {FileDirectory localNameFor: fullFileName}) . selection = 1 ifTrue: [^ self new open: fullFileName forWrite: true]. selection = 2 ifTrue: [ newName := FillInTheBlank request: 'Enter a new file name' translated initialAnswer: fullFileName. ^ self oldFileNamed: (self fullName: newName)]. + ^ self error: 'Could not open a file' translated! - ^ self error: 'Could not open a file'! Item was changed: ----- Method: StandardFileStream class>>readOnlyFileDoesNotExistUserHandling: (in category '*Etoys-Squeakland-error handling') ----- readOnlyFileDoesNotExistUserHandling: fullFileName | dir files choices selection newName fileName | dir := FileDirectory forFileName: fullFileName. files := dir fileNames. fileName := FileDirectory localNameFor: fullFileName. choices := fileName correctAgainst: files. choices add: 'Choose another name' translated. choices add: 'Cancel' translated. selection := (PopUpMenu labelArray: choices lines: (Array with: 5) ) startUpWithCaption: ( '{1} does not exist.' translated format: {FileDirectory localNameFor: fullFileName}). selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"]. selection < (choices size - 1) ifTrue: [ newName := (dir pathName , FileDirectory slash , (choices at: selection))]. selection = (choices size - 1) ifTrue: [ newName := FillInTheBlank request: 'Enter a new file name' translated initialAnswer: fileName]. newName = '' ifFalse: [^ self readOnlyFileNamed: (self fullName: newName)]. + ^ self error: 'Could not open a file' translated! - ^ self error: 'Could not open a file'!

1 0

The Trunk: Compression-ct.57.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of Compression to project The Trunk: http://source.squeak.org/trunk/Compression-ct.57.mcz ==================== Summary ==================== Name: Compression-ct.57 Author: ct Time: 3 January 2022, 7:17:31.519703 pm UUID: 32eabe2a-30cb-9e45-9820-3f00c262870f Ancestors: Compression-dtl.55 Fixes ZipWriteStream regression tests. The file stream under test, and thus FastInflateStream, streams bytes rather than chracters, so provide ByteArrays rather than strings as target buffers. =============== Diff against Compression-dtl.55 =============== Item was changed: ----- Method: ZipWriteStream class>>regressionDecompress:from:notifying:stats: (in category 'regression test') ----- regressionDecompress: aFile from: tempFile notifying: progressBar stats: stats "Validate aFile as decompressed from tempFile" | unzip rawSize compressedSize buffer1 buffer2 | rawSize := aFile size. compressedSize := tempFile size. aFile ascii. aFile position: 0. tempFile ascii. tempFile position: 0. + buffer1 := ByteArray new: 4096. - buffer1 := String new: 4096. buffer2 := buffer1 copy. unzip := FastInflateStream on: tempFile. [aFile atEnd] whileFalse:[ progressBar value: aFile position. buffer1 := aFile nextInto: buffer1. buffer2 := unzip nextInto: buffer2. buffer1 = buffer2 ifFalse:[^self logProblem: 'contents ' for: aFile]. ]. unzip next = nil ifFalse:[^self logProblem: 'EOF' for: aFile]. stats at: #rawSize put: (stats at: #rawSize ifAbsent:[0]) + rawSize. stats at: #compressedSize put: (stats at: #compressedSize ifAbsent:[0]) + compressedSize. ^compressedSize asFloat / rawSize asFloat.!

1 0

Jump to page: