Chris Muller uploaded a new version of System to project The Treated Inbox: http://source.squeak.org/treated/System-cmm.1145.mcz
==================== Summary ====================
Name: System-cmm.1145 Author: cmm Time: 31 August 2022, 4:57:27.059229 pm UUID: 65825d0e-dee7-4791-8d61-66d1bd07022a Ancestors: System-cmm.1144
new server email test. Ignore.
=============== Diff against System-mt.1142 ===============
Item was changed: ----- Method: CommunityTheme class>>addDarkScrollables: (in category 'instance creation') ----- addDarkScrollables: aUserInterfaceTheme "self createDark apply." "Scroll bars" aUserInterfaceTheme set: #thumbColor for: #ScrollBar to: self dbGray; set: #thumbBorderColor for: #ScrollBar to: self dbGray twiceDarker. "Scroll panes (includes generic stuff for list widgets, tree widgets, and text widgets." aUserInterfaceTheme set: #borderColor for: #ScrollPane to: (Color transparent) ; "So the search box isn't outlined." set: #color for: #ScrollPane to: self dbBackground. "List widgets" aUserInterfaceTheme set: #textColor for: #PluggableListMorph to: (Color gray: 0.9); set: #selectionColor for: #PluggableListMorph to: self dbSelection; set: #selectionTextColor for: #PluggableListMorph to: Color white ; derive: #multiSelectionColor for: #PluggableListMorph from: #PluggableListMorph at: #selectionColor do: [:c | c twiceDarker]; set: #filterColor for: #PluggableListMorph to: (self dbYellow alpha: 0.4); derive: #filterTextColor for: #PluggableListMorph from: #PluggableListMorph at: #textColor ; set: #preSelectionModifier for: #PluggableListMorph to: [ [:c | c twiceDarker ] ]; set: #hoverSelectionModifier for: #PluggableListMorph to: [ [:c | c twiceDarker alpha: 0.5 ] ]. "Tree widgets" aUserInterfaceTheme set: #highlightTextColor for: #SimpleHierarchicalListMorph to: self dbYellow lighter lighter; set: #lineColor for: #SimpleHierarchicalListMorph to: Color gray. "Text widgets" aUserInterfaceTheme set: #textColor for: #PluggableTextMorph to: (Color gray: 0.9); set: #caretColor for: #PluggableTextMorph to: Color orange darker; set: #selectionColor for: #PluggableTextMorph to: (self dbSelection duller duller); set: #unfocusedSelectionModifier for: #PluggableTextMorph to: [ [:c | c duller] ]; set: #adornmentReadOnly for: #PluggableTextMorph to: self dbPurple; set: #adornmentRefuse for: #PluggableTextMorph to: self dbBlue; set: #adornmentConflict for: #PluggableTextMorph to: self dbRed; set: #adornmentDiff for: #PluggableTextMorph to: self dbGreen; set: #adornmentNormalEdit for: #PluggableTextMorph to: self dbOrange; set: #adornmentDiffEdit for: #PluggableTextMorph to: self dbYellow; set: #frameAdornmentWidth for: #PluggableTextMorph to: 2. aUserInterfaceTheme + set: #balloonTextColor for: #PluggableTextMorphPlus to: self dbComment! - set: #balloonTextColor for: #PluggableTextMorphPlus to: Color lightGray!
Item was changed: ----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn') ----- comeFullyUpOnReload: smartRefStream "fix up the objects in the segment that changed size. An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size. Replace the modern class with the old one in outPointers. Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages. Keep the new instances. Bulk forward become the old to the new. Let go of the fake objects and classes. After the install (below), arrayOfRoots is filled in. Globalize new classes. Caller may want to do some special install on certain objects in arrayOfRoots. May want to write the segment out to disk in its new form."
| mapFakeClassesToReal receiverClasses rootsToUnhiberhate myProject existing forgetDoItsClass endianness |
forgetDoItsClass := Set new. RecentlyRenamedClasses := nil. "in case old data hanging around" mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers. "Dictionary of just the ones that change shape. Substitute them in outPointers." self fixCapitalizationOfSymbols. endianness := self endianness. segment := self loadSegmentFrom: segment outPointers: outPointers. arrayOfRoots := segment first. mapFakeClassesToReal isEmpty ifFalse: [ self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream ]. "When a Project is stored, arrayOfRoots has all objects in the project, except those in outPointers" arrayOfRoots do: [:importedObject | ((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [ importedObject mutateJISX0208StringToUnicode. importedObject class = WideSymbol ifTrue: [ "self halt." Symbol hasInterned: importedObject asString ifTrue: [:multiSymbol | multiSymbol == importedObject ifFalse: [ importedObject becomeForward: multiSymbol. ]. ]. ]. ]. (importedObject isMemberOf: TTCFontSet) ifTrue: [ existing := TTCFontSet familyName: importedObject familyName pointSize: importedObject pointSize. "supplies default" existing == importedObject ifFalse: [importedObject becomeForward: existing]. ]. ].
receiverClasses := self restoreEndianness: endianness ~~ Smalltalk endianness. "rehash sets" smartRefStream checkFatalReshape: receiverClasses.
"Classes in this segment." arrayOfRoots do: [:importedObject | importedObject class class == Metaclass ifTrue: [forgetDoItsClass add: importedObject. self declare: importedObject]]. rootsToUnhiberhate := OrderedCollection new. arrayOfRoots do: [:importedObject | ((importedObject isMemberOf: ScriptEditorMorph) or: [(importedObject isKindOf: TileMorph) or: [(importedObject isMemberOf: ScriptingTileHolder) or: [importedObject isKindOf: CompoundTileMorph]]]) ifTrue: [ rootsToUnhiberhate add: importedObject ]. (importedObject isMemberOf: Project) ifTrue: [ myProject := importedObject. importedObject ensureChangeSetNameUnique. Project addingProject: importedObject. importedObject restoreReferences. self dependentsRestore: importedObject. ScriptEditorMorph writingUniversalTiles: ((importedObject projectPreferenceAt: #universalTiles) ifNil: [false])]].
myProject ifNotNil: [ myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray. ].
mapFakeClassesToReal isEmpty ifFalse: [ mapFakeClassesToReal keysAndValuesDo: [:aFake :aReal | aFake removeFromSystemUnlogged. aFake becomeForward: aReal]. SystemOrganization removeEmptyCategories]. + forgetDoItsClass do: [:c | c forgetDoIts]. - forgetDoItsClass do: [:c | self forgetDoItsInClass: c]. "^ self" !
Item was removed: - ----- Method: ImageSegment>>forgetDoItsInClass: (in category 'private') ----- - forgetDoItsInClass: aClass - "get rid of old DoIt methods and bogus entries in the ClassOrganizer." - - SystemChangeNotifier uniqueInstance doSilently: [ - aClass organization - removeElement: #DoIt; - removeElement: #DoItIn:. - ]. - - aClass - basicRemoveSelector: #DoIt; - basicRemoveSelector: #DoItIn:!
Item was changed: ----- Method: Locale class>>defaultInputInterpreter (in category 'platform specific') ----- defaultInputInterpreter + | platformName osVersion | - | platformName | platformName := Smalltalk platformName. + osVersion := Smalltalk getSystemAttribute: 1002. + (platformName = 'Win32' and: [osVersion = 'CE']) + ifTrue: [^NoInputInterpreter new]. + platformName = 'Win32' ifTrue: [^MacRomanInputInterpreter new]. - platformName = 'Win32' ifTrue: [^UTF32InputInterpreter new]. ^NoInputInterpreter new!
Item was changed: ----- Method: NativeImageSegment>>rootsIncludingBlocks (in category 'read/write segment') ----- rootsIncludingBlocks "For export segments only. Return a new roots array with more objects. (Caller should store into rootArray.) Collect Blocks and external methods pointed to by them. Put them into the roots list. Then ask for the segment again."
| extras have | userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. extras := OrderedCollection new. outPointers do: [:anOut | anOut class == CompiledMethod ifTrue: [extras add: anOut]. (anOut isBlock) ifTrue: [extras add: anOut]. (anOut class == Context) ifTrue: [extras add: anOut]].
[have := extras size. extras copy do: [:anOut | anOut isBlock ifTrue: [ anOut home ifNotNil: [ (extras includes: anOut home) ifFalse: [extras add: anOut home]]]. + (anOut class == MethodContext) ifTrue: [ - (anOut class == Context) ifTrue: [ anOut method ifNotNil: [ (extras includes: anOut method) ifFalse: [extras add: anOut method]]]]. have = extras size] whileFalse. extras := extras select: [:ea | (arrayOfRoots includes: ea) not]. extras isEmpty ifTrue: [^ nil]. "no change"
^ arrayOfRoots, extras!
Item was changed: ----- Method: NativeImageSegment>>storeDataOn: (in category 'fileIn/Out') ----- storeDataOn: aDataStream "Don't wrote the array of Roots. Also remember the structures of the classes of objects inside the segment."
| tempRoots tempOutP list | state = #activeCopy ifFalse: [self error: 'wrong state']. "real state is activeCopy, but we changed it will be right when coming in" tempRoots := arrayOfRoots. tempOutP := outPointers. outPointers := outPointers shallowCopy. self prepareToBeSaved. arrayOfRoots := nil. state := #imported. super storeDataOn: aDataStream. "record my inst vars" arrayOfRoots := tempRoots. outPointers := tempOutP. state := #activeCopy. aDataStream references at: #AnImageSegment put: false. "the false is meaningless" "This key in refs is the flag that there is an ImageSegment in this file."
"Find the receivers of blocks in the segment. Need to get the structure of their classes into structures. Put the receivers into references." (aDataStream byteStream isKindOf: DummyStream) ifTrue: [ list := Set new. arrayOfRoots do: [:ea | ea isBlock | (ea class == Context) ifTrue: [ list add: ea receiver class ]]. aDataStream references at: #BlockReceiverClasses put: list].!
Item was changed: ----- Method: Preferences class>>loadPreferencesFrom: (in category 'initialization - save/load') ----- loadPreferencesFrom: aFile + + | stream params dict desktopColor patternsToIgnore | + patternsToIgnore := #('*updateMapName' '*defaultUpdateURL'). - | stream params dict desktopColor | stream := ReferenceStream fileNamed: aFile. params := stream next. self assert: (params isKindOf: IdentityDictionary). params removeKey: #PersonalDictionaryOfPreferences. dict := stream next. self assert: (dict isKindOf: IdentityDictionary). desktopColor := stream next. stream close. + dict keys + reject: [:key | patternsToIgnore anySatisfy: [:pattern | pattern match: key]] + thenDo: [:key | | value | + value := dict at: key. + (self preferenceAt: key ifAbsent: [nil]) ifNotNil: + [:pref | [pref preferenceValue: value preferenceValue] + on: Deprecation do: [ : err | "Ignore preferences which may not be supported anymore."]]]. - dict keysAndValuesDo: - [:key :value | (self preferenceAt: key ifAbsent: [nil]) ifNotNil: - [:pref | [pref preferenceValue: value preferenceValue] on: Deprecation do: [ : err | "Ignore preferences which may not be supported anymore."]]]. params keysAndValuesDo: [ :key :value | self setParameter: key to: value ]. Smalltalk isMorphic ifTrue: [ Project current world fillStyle: desktopColor ] ifFalse: [ self desktopColor: desktopColor. ScheduledControllers updateGray ]!
Item was changed: ----- Method: Preferences class>>setFlag:toValue:during: (in category 'get/set - flags') ----- setFlag: prefSymbol toValue: aBoolean during: aBlock "Set the flag to the given value for the duration of aBlock"
(self valueOfFlag: prefSymbol) in: [:previous | self setFlag: prefSymbol toValue: aBoolean. + aBlock ensure: [self setFlag: prefSymbol toValue: previous]].! - ^ aBlock ensure: [self setFlag: prefSymbol toValue: previous]].!
Item was changed: ----- Method: Preferences class>>setPreference:toValue:during: (in category 'get/set') ----- setPreference: prefSymbol toValue: anObject during: aBlock
(self valueOfPreference: prefSymbol) in: [:previous | self setPreference: prefSymbol toValue: anObject. + aBlock ensure: [self setPreference: prefSymbol toValue: previous]].! - ^ aBlock ensure: [self setPreference: prefSymbol toValue: previous]]!
Item was changed: ----- Method: Preferences class>>storePreferencesIn: (in category 'initialization - save/load') ----- storePreferencesIn: aFileName | stream prefsSnapshot | #(Prevailing PersonalPreferences) do: [:ea | Parameters removeKey: ea ifAbsent: []]. stream := ReferenceStream fileNamed: aFileName. stream nextPut: Parameters. prefsSnapshot := preferencesDictionary copy. + prefsSnapshot keysAndValuesDo: [:key :pref | + [prefsSnapshot at: key put: pref asPreference] + on: Deprecation do: [ : err | "Ignore preferences which may not be supported anymore."]]. - prefsSnapshot keysAndValuesDo: [:key :pref | prefsSnapshot at: key put: pref asPreference]. stream nextPut: prefsSnapshot. stream nextPut: (Smalltalk isMorphic ifTrue:[Project current world fillStyle] ifFalse:[self desktopColor]). stream close!
Item was added: + ----- Method: SmalltalkImage class>>test (in category 'instance creation') ----- + test + !
Item was changed: ----- Method: SmalltalkImage>>openSourceFiles (in category 'sources, changes log') ----- openSourceFiles + self startingUpInNewLocation ifTrue: + [ "Reset the author initials to blank when the image gets moved" - - self imageName = LastImageName ifFalse: - ["Reset the author initials to blank when the image gets moved" LastImageName := self imageName. + Utilities authorInitials: String empty ]. - Utilities authorInitials: '']. FileDirectory openSources: self sourcesName andChanges: self changesName forImage: LastImageName. SourceFileArray install!
Item was changed: ----- Method: SmalltalkImage>>patchSystem (in category 'command line') ----- patchSystem 'patch.st' asDirectoryEntry ifNotNil: [ : patchEntry | patchEntry modificationTime > Smalltalk imageName asDirectoryEntry modificationTime ifTrue: [ Notification signal: 'Patching system...'. + patchEntry readStreamDo: [ : stream | stream fileIn ] ] - FileStream - fileNamed: 'patch.st' - do: - [ : stream | stream fileIn ] ] ifFalse: [ self error: 'patch.st file is older than the image file. Aborting.' ] ]!
Item was changed: ----- Method: SmalltalkImage>>run: (in category 'command line') ----- run: aBlock [ [ self patchSystem. (aBlock numArgs = 1 and: [ self arguments size > 1 ]) ifTrue: [ "Allow a large, variable number of arguments to be passed as an Array to aBlock." aBlock value: self arguments ] ifFalse: [ aBlock valueWithEnoughArguments: self arguments ] ] - on: ProgressInitiationException - do: - [ : pie | "Don't want to log this notification." - pie defaultAction ] ] - on: Notification , Warning - do: - [ : noti | FileStream stdout - nextPutAll: DateAndTime now asString ; - space ; - nextPutAll: noti description ; - cr. - noti resume ] on: SyntaxErrorNotification do: [ : err | FileStream stdout nextPutAll: err errorCode ; cr; flush. self isHeadless ifTrue: [ self snapshot: false andQuit: true ] ifFalse: [ err pass ] ] + on: Error , ProvideAnswerNotification - on: Error do: [ : err | err printVerboseOn: FileStream stderr. FileStream stderr flush. self isHeadless ifTrue: [ self snapshot: false andQuit: true ] + ifFalse: [ err pass ] ] + on: ProgressInitiationException + do: + [ : pie | "Don't want to log this Notification." + pie defaultAction ] ] + on: Notification , Warning + do: + [ : noti | FileStream stdout + nextPutAll: DateAndTime now asString ; + space ; + nextPutAll: noti description ; + cr. + noti resume ] + ! - ifFalse: [ err pass ] ]!
Item was added: + ----- Method: SmalltalkImage>>startingUpInNewLocation (in category 'startup list') ----- + startingUpInNewLocation + ^ self imageName ~= LastImageName!
Item was changed: ----- Method: SystemNavigation class>>privateAuthorsRaw (in category 'class initialization') ----- (excessive size, no diff calculated)
Item was changed: ----- Method: UserInterfaceThemeRequest>>doesNotUnderstand: (in category 'lookup') ----- doesNotUnderstand: aMessage "Look up the visual attribute specified by aMessage's #selector in the current theme for the current target object."
aMessage numArgs = 0 ifTrue: [ ^ (self theme get: self target class -> aMessage selector) ifNil: [(self theme respondsTo: aMessage selector) ifTrue: [self theme perform: aMessage selector] ifFalse: [nil "unset property"]]]. - aMessage numArgs = 1 ifTrue: [ - ^ self theme - set: self target class -> aMessage selector asSimpleGetter - to: aMessage arguments first]. - ^ self theme perform: aMessage selector withArguments: aMessage arguments.!
Item was changed: ----- Method: Utilities class>>useAuthorInitials:during: (in category 'identification') ----- useAuthorInitials: temporaryAuthorInitials during: aBlock
| originalAuthorInitials | originalAuthorInitials := AuthorInitials. + [ + AuthorInitials := temporaryAuthorInitials. + aBlock value ] - ^[ AuthorInitials := temporaryAuthorInitials. - aBlock value ] ensure: [ AuthorInitials := originalAuthorInitials ] !
Item was changed: ----- Method: Utilities class>>useAuthorName:during: (in category 'identification') ----- useAuthorName: temporaryAuthorName during: aBlock
| originalAuthorName | originalAuthorName := AuthorName. + [ + AuthorName := temporaryAuthorName. + aBlock value ] - ^[ AuthorName := temporaryAuthorName. - aBlock value ] ensure: [ AuthorName := originalAuthorName ] !
Item was changed: + (PackageInfo named: 'System') postscript: 'SystemNavigation initializeAuthors.'! - (PackageInfo named: 'System') postscript: 'Preferences removePreference: #bigDisplay.'!