[Pkg] The Trunk: System-nice.203.mcz
commits at source.squeak.org
commits at source.squeak.org
Sun Dec 27 02:51:02 UTC 2009
Nicolas Cellier uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-nice.203.mcz
==================== Summary ====================
Name: System-nice.203
Author: nice
Time: 27 December 2009, 3:50:10 am
UUID: acbaa23f-b646-4062-b579-36540e0d996b
Ancestors: System-nice.202
Cosmetic: move or remove a few temps inside closures
=============== Diff against System-nice.202 ===============
Item was changed:
----- Method: SystemNavigation>>browseUncommentedMethodsWithInitials: (in category 'browse') -----
browseUncommentedMethodsWithInitials: targetInitials
"Browse uncommented methods whose initials (in the time-stamp, as logged to disk) match the given initials. Present them in chronological order. CAUTION: It will take several minutes for this to complete."
"Time millisecondsToRun: [SystemNavigation default browseUncommentedMethodsWithInitials: 'jm']"
+ | methodReferences |
- | initials timeStamp methodReferences cm |
methodReferences := OrderedCollection new.
self allBehaviorsDo:
+ [:aClass | aClass selectorsDo: [:sel | | timeStamp initials cm |
- [:aClass | aClass selectorsDo: [:sel |
cm := aClass compiledMethodAt: sel.
timeStamp := Utilities timeStampForMethod: cm.
timeStamp isEmpty ifFalse:
[initials := timeStamp substrings first.
initials first isDigit ifFalse:
[((initials = targetInitials) and: [(aClass firstPrecodeCommentFor: sel) isNil])
ifTrue:
[methodReferences add: (MethodReference new
setStandardClass: aClass
methodSymbol: sel)]]]]].
ToolSet
browseMessageSet: methodReferences
name: 'Uncommented methods with initials ', targetInitials
autoSelect: nil!
Item was changed:
----- Method: SystemNavigation>>allUnimplementedNonPrimitiveCalls (in category 'query') -----
allUnimplementedNonPrimitiveCalls
"Answer an Array of each message that is sent by an expression in a
method but is not implemented by any object in the system."
+ | aStream all |
- | aStream secondStream all meth |
all := self systemNavigation allImplementedMessages.
aStream := WriteStream
on: (Array new: 50).
Cursor execute
showWhile: [self systemNavigation
allBehaviorsDo: [:cl | cl
+ selectorsDo: [:sel | | secondStream meth |
- selectorsDo: [:sel |
secondStream := WriteStream
on: (String new: 5).
meth := cl compiledMethodAt: sel.
meth primitive = 0 ifTrue: [
meth messages
do: [:m | (all includes: m)
ifFalse: [secondStream nextPutAll: m;
space]].
secondStream position = 0
ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]]].
^ aStream contents!
Item was changed:
----- Method: ImageSegment>>dependentsSave: (in category 'read/write segment') -----
dependentsSave: dummy
"Object that have dependents are supposed to be instances of subclasses of Model. But, class Objects still provides 'Global Dependents', and some people still use them. When both the model and the dependent are in a project that is being saved, remember them, so we can hook them up when this project is loaded in."
+ | dict proj |
- | dict proj list |
proj := dummy project.
dict := Dictionary new.
+ DependentsFields associationsDo: [:assoc | | list |
- DependentsFields associationsDo: [:assoc |
(dummy references includesKey: assoc key) ifTrue: [
list := assoc value select: [:dd | dummy references includesKey: dd].
list size > 0 ifTrue: [dict at: assoc key put: list]]].
dict size > 0 ifTrue: [
proj projectParameterAt: #GlobalDependentsInProject put: dict].
!
Item was changed:
----- Method: SmartRefStream>>uniClasesDo: (in category 'read write') -----
uniClasesDo: aBlock
"Examine structures and execute the block with each instance-specific class"
+
+ structures keysDo: [:clsName | | cls |
- | cls |
- structures keysDo: [:clsName |
(clsName endsWith: ' class') ifFalse: [
(cls := Smalltalk at: clsName) isSystemDefined ifFalse: [
aBlock value: cls]]]!
Item was changed:
----- Method: ImageSegment>>copySmartRootsExport: (in category 'read/write segment') -----
copySmartRootsExport: rootArray
"Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray."
+ | newRoots list segSize symbolHolder replacements naughtyBlocks allClasses sizeHint proj dummy |
- | newRoots list segSize symbolHolder dummy replacements naughtyBlocks goodToGo allClasses sizeHint proj |
Smalltalk forgetDoIts.
"self halt."
symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers,
so they will be in outPointers"
dummy := ReferenceStream on: (DummyStream on: nil).
"Write to a fake Stream, not a file"
"Collect all objects"
dummy insideASegment: true. "So Uniclasses will be traced"
dummy rootObject: rootArray. "inform him about the root"
dummy nextPut: rootArray.
(proj :=dummy project) ifNotNil: [self dependentsSave: dummy].
allClasses := SmartRefStream new uniClassInstVarsRefs: dummy.
"catalog the extra objects in UniClass inst vars. Put into dummy"
allClasses do: [:cls |
dummy references at: cls class put: false. "put Player5 class in roots"
dummy blockers removeKey: cls class ifAbsent: []].
"refs := dummy references."
arrayOfRoots := self smartFillRoots: dummy. "guaranteed none repeat"
self savePlayerReferences: dummy references. "for shared References table"
replacements := dummy blockers.
dummy project "recompute it" ifNil: [self error: 'lost the project!!'].
dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project'].
dummy := nil. "force GC?"
naughtyBlocks := arrayOfRoots select: [ :each |
(each isKindOf: ContextPart) and: [each hasInstVarRef]
].
"since the caller switched ActiveWorld, put the real one back temporarily"
naughtyBlocks isEmpty ifFalse: [
+ World becomeActiveDuring: [ | goodToGo |
- World becomeActiveDuring: [
goodToGo := (UIManager default
chooseFrom: #('keep going' 'stop and take a look')
title:
'Some block(s) which reference instance variables
are included in this segment. These may fail when
the segment is loaded if the class has been reshaped.
What would you like to do?') == 1.
goodToGo ifFalse: [
naughtyBlocks inspect.
self error: 'Here are the bad blocks'].
].
].
"Creation of the segment happens here"
"try using one-quarter of memory min: four megs to publish (will get bumped later)"
sizeHint := (Smalltalk garbageCollect // 4 // 4) min: 1024*1024.
self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true.
segSize := segment size.
[(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [
arrayOfRoots := newRoots.
self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
"with methods pointed at from outside"
[(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [
arrayOfRoots := newRoots.
self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
"with methods, blocks from outPointers"
list := self compactClassesArray.
outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
1 to: outPointers size do: [:ii |
(outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil].
(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil].
"substitute new object in outPointers"
(replacements includesKey: (outPointers at: ii)) ifTrue: [
outPointers at: ii put: (replacements at: (outPointers at: ii))]].
proj ifNotNil: [self dependentsCancel: proj].
symbolHolder.!
Item was changed:
----- Method: SystemDictionary>>condenseChanges (in category 'housekeeping') -----
condenseChanges
"Move all the changes onto a compacted sources file."
"Smalltalk condenseChanges"
+ | f oldChanges |
- | f oldChanges count |
f := FileStream fileNamed: 'ST80.temp'.
f header; timeStamp.
'Condensing Changes File...'
displayProgressAt: Sensor cursorPoint
from: 0
to: self classNames size + self traitNames size
+ during: [:bar | | count |
- during: [:bar |
count := 0.
self
allClassesAndTraitsDo: [:classOrTrait |
bar value: (count := count + 1).
classOrTrait moveChangesTo: f.
classOrTrait putClassCommentToCondensedChangesFile: f.
classOrTrait classSide moveChangesTo: f]].
SmalltalkImage current lastQuitLogPosition: f position.
f trailer; close.
oldChanges := SourceFiles at: 2.
oldChanges close.
FileDirectory default deleteFileNamed: oldChanges name , '.old';
rename: oldChanges name toBe: oldChanges name , '.old';
rename: f name toBe: oldChanges name.
self setMacFileInfoOn: oldChanges name.
SourceFiles
at: 2
put: (FileStream oldFileNamed: oldChanges name)!
Item was changed:
----- Method: MessageTally>>treePrintOn:tabs:thisTab:total:totalTime:tallyExact:orThreshold: (in category 'printing') -----
treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold
+ | sons |
- | sons sonTab |
tabs do: [:tab | aStream nextPutAll: tab].
tabs size > 0
ifTrue:
[self
printOn: aStream
total: total
totalTime: totalTime
tallyExact: isExact].
sons := isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold].
sons isEmpty
ifFalse:
[tabs addLast: myTab.
sons := sons asSortedCollection.
(1 to: sons size) do:
+ [:i | | sonTab |
- [:i |
sonTab := i < sons size ifTrue: [' |'] ifFalse: [' '].
(sons at: i)
treePrintOn: aStream
tabs: (tabs size < self maxTabs
ifTrue: [tabs]
ifFalse: [(tabs select: [:x | x = '[']) copyWith: '['])
thisTab: sonTab
total: total
totalTime: totalTime
tallyExact: isExact
orThreshold: threshold].
tabs removeLast]!
Item was changed:
----- Method: SystemNavigation>>allUnimplementedCalls (in category 'query') -----
allUnimplementedCalls
"Answer an Array of each message that is sent by an expression in a
method but is not implemented by any object in the system."
+ | aStream all |
- | aStream secondStream all |
all := self allImplementedMessages.
aStream := WriteStream
on: (Array new: 50).
Cursor execute
showWhile: [self
allBehaviorsDo: [:cl | cl
+ selectorsDo: [:sel | | secondStream |
- selectorsDo: [:sel |
secondStream := WriteStream
on: (String new: 5).
(cl compiledMethodAt: sel) messages
do: [:m | (all includes: m)
ifFalse: [secondStream nextPutAll: m;
space]].
secondStream position = 0
ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]].
^ aStream contents!
Item was changed:
----- Method: ChangeSet>>methodsWithoutClassifications (in category 'testing') -----
methodsWithoutClassifications
"Return a collection representing methods in the receiver which have not been categorized"
+ | slips notClassified |
- | slips notClassified aSelector |
notClassified := {'as yet unclassified' asSymbol. #all}.
slips := OrderedCollection new.
self changedClasses do:
[:aClass |
(self methodChangesAtClass: aClass name) associationsDo:
+ [:mAssoc | | aSelector | (aClass includesSelector: (aSelector := mAssoc key)) ifTrue:
- [:mAssoc | (aClass includesSelector: (aSelector := mAssoc key)) ifTrue:
[(notClassified includes: (aClass organization categoryOfElement: aSelector))
ifTrue: [slips add: aClass name , ' ' , aSelector]]]].
^ slips
"Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"!
Item was changed:
----- Method: ChangeSet class>>gatherChangeSets (in category 'enumerating') -----
gatherChangeSets "ChangeSet gatherChangeSets"
"Collect any change sets created in other projects"
+ | allChangeSets |
- | allChangeSets obsolete |
allChangeSets := AllChangeSets asSet.
+ ChangeSet allSubInstances do: [:each | | obsolete |
- ChangeSet allSubInstances do: [:each |
(allChangeSets includes: each) == (obsolete := each isMoribund) ifTrue:[
obsolete
ifTrue: ["Was included and is obsolete."
AllChangeSets remove: each]
ifFalse: ["Was not included and is not obsolete."
AllChangeSets add: each]]].
^ AllChangeSets!
Item was changed:
----- Method: SmartRefStream>>reshapedClassesIn: (in category 'import image segment') -----
reshapedClassesIn: outPointers
"Look for classes in the outPointer array that have changed shape. Make a fake class for the old shape. Return a dictionary mapping Fake classes to Real classes. Substitute fake classes for real ones in outPointers."
+ | mapFakeClassesToReal |
- | mapFakeClassesToReal fakeCls originalName |
self flag: #bobconv.
mapFakeClassesToReal := IdentityDictionary new.
+ outPointers withIndexDo: [:outp :ind | | originalName fakeCls |
- outPointers withIndexDo: [:outp :ind |
outp isBehavior ifTrue: [
originalName := renamedConv at: ind ifAbsent: [outp name].
"in DiskProxy>>comeFullyUpOnReload: we saved the name at the index"
fakeCls := self mapClass: outp origName: originalName.
fakeCls == outp ifFalse: [
mapFakeClassesToReal at: fakeCls put: outp.
outPointers at: ind put: fakeCls]]].
^ mapFakeClassesToReal!
Item was changed:
----- Method: SystemDictionary>>condenseSources (in category 'housekeeping') -----
condenseSources
"Move all the changes onto a compacted sources file."
"Smalltalk condenseSources"
+ | f dir newVersionString |
- | f dir newVersionString count |
Utilities fixUpProblemsWithAllCategory.
"The above removes any concrete, spurious '-- all --' categories, which mess up the process."
dir := FileDirectory default.
newVersionString := UIManager default request: 'Please designate the version
for the new source code file...' initialAnswer: SmalltalkImage current sourceFileVersionString.
newVersionString ifNil: [^ self].
newVersionString = SmalltalkImage current sourceFileVersionString ifTrue:
[^ self error: 'The new source file must not be the same as the old.'].
SmalltalkImage current sourceFileVersionString: newVersionString.
"Write all sources with fileIndex 1"
f := FileStream newFileNamed: SmalltalkImage current sourcesName.
f header; timeStamp.
'Condensing Sources File...'
displayProgressAt: Sensor cursorPoint
from: 0 to: self classNames size + self traitNames size
during:
+ [:bar | | count | count := 0.
- [:bar | count := 0.
Smalltalk allClassesAndTraitsDo:
[:classOrTrait | bar value: (count := count + 1).
classOrTrait fileOutOn: f moveSource: true toFile: 1]].
f trailer; close.
"Make a new empty changes file"
SmalltalkImage current closeSourceFiles.
dir rename: SmalltalkImage current changesName
toBe: SmalltalkImage current changesName , '.old'.
(FileStream newFileNamed: SmalltalkImage current changesName)
header; timeStamp; close.
SmalltalkImage current lastQuitLogPosition: 0.
self setMacFileInfoOn: SmalltalkImage current changesName.
self setMacFileInfoOn: SmalltalkImage current sourcesName.
SmalltalkImage current openSourceFiles.
self inform: 'Source files have been rewritten!!
Check that all is well,
and then save/quit.'!
Item was changed:
----- Method: SystemDictionary>>renameClass:from: (in category 'class names') -----
renameClass: aClass from: oldName
"Rename the class, aClass, to have the title newName."
+ | oldref newName category |
- | oldref i newName category |
newName := aClass name.
category := SystemOrganization categoryOfElement: oldName.
SystemOrganization classify: newName under: category.
SystemOrganization removeElement: oldName.
oldref := self associationAt: oldName.
self removeKey: oldName.
oldref key: newName.
self add: oldref. "Old association preserves old refs"
(Array with: StartUpList with: ShutDownList) do:
+ [:list | | i | i := list indexOf: oldName ifAbsent: [0].
- [:list | i := list indexOf: oldName ifAbsent: [0].
i > 0 ifTrue: [list at: i put: newName]].
self flushClassNameCache.
SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category!
Item was changed:
----- Method: SmartRefStream>>saveClassInstVars (in category 'read write') -----
saveClassInstVars
"Install the values of the instance variables of UniClasses.
classInstVars is an array of arrays (#Player3 (Player3 class's inst var
scripts) (Player3 class's inst var slotInfo) ...) "
+ | normal clsPoolIndex |
- | normal mySize list clsPoolIndex |
classInstVars := OrderedCollection new: 100.
normal := Object class instSize.
clsPoolIndex := Object class allInstVarNames indexOf: 'classPool'.
+ self uniClasesDo: [:aUniClass | | list mySize |
- self uniClasesDo: [:aUniClass |
list := OrderedCollection new.
mySize := aUniClass class instSize.
mySize = normal ifFalse:
[list add: aUniClass name. "a symbol"
list add: 'Update to read classPool'. "new
convention for saving the classPool"
list add: (aUniClass instVarAt: clsPoolIndex)
"classPool".
"write actual value of nil
instead of Dictionary()"
normal + 1 to: mySize do: [:ii |
list addLast: (aUniClass instVarAt: ii)].
classInstVars add: list asArray]].
classInstVars := classInstVars asArray.
!
Item was changed:
----- Method: SystemDictionary>>testFormatter2 (in category 'housekeeping') -----
testFormatter2
"Smalltalk testFormatter2"
"Reformats the source for every method in the system, and
then verifies that the order of source tokens is unchanged.
The formatting used will be either classic monochrome or
fancy polychrome, depending on the setting of the preference
#colorWhenPrettyPrinting. "
"Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
+ | badOnes |
- | newCodeString badOnes n oldCodeString oldTokens newTokens |
badOnes := OrderedCollection new.
self forgetDoIts.
'Formatting all classes...'
displayProgressAt: Sensor cursorPoint
from: 0
to: CompiledMethod instanceCount
during:
+ [:bar | | n |
- [:bar |
n := 0.
self systemNavigation allBehaviorsDo:
[:cls |
"Transcript cr; show: cls name."
cls selectorsDo:
+ [:selector | | newCodeString oldCodeString oldTokens newTokens |
- [:selector |
(n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
oldCodeString := (cls sourceCodeAt: selector) asString.
newCodeString := cls prettyPrinterClass
format: oldCodeString
in: cls
notifying: nil
decorated: false.
oldTokens := oldCodeString findTokens: Character separators.
newTokens := newCodeString findTokens: Character separators.
oldTokens = newTokens
ifFalse:
[Transcript
cr;
show: '***' , cls name , ' ' , selector.
badOnes add: cls name , ' ' , selector]]]].
self systemNavigation browseMessageList: badOnes asSortedCollection
name: 'Formatter Discrepancies'!
Item was changed:
----- Method: MessageTally>>spyAllEvery:on: (in category 'initialize-release') -----
spyAllEvery: millisecs on: aBlock
"Create a spy and spy on the given block at the specified rate."
"Spy all the system processes"
+ | myDelay time0 |
- | myDelay startTime time0 observedProcess |
(aBlock isBlock)
ifFalse: [self error: 'spy needs a block here'].
self class: aBlock receiver class method: aBlock method.
"set up the probe"
myDelay := Delay forMilliseconds: millisecs.
time0 := Time millisecondClockValue.
gcStats := SmalltalkImage current getVMParameters.
+ Timer := [ | startTime observedProcess |
- Timer := [
[true] whileTrue: [
startTime := Time millisecondClockValue.
myDelay wait.
observedProcess := Processor preemptedProcess.
self tally: observedProcess suspendedContext
in: (ShowProcesses ifTrue: [observedProcess])
"tally can be > 1 if ran a long primitive"
by: (Time millisecondClockValue - startTime) // millisecs].
nil] newProcess.
Timer priority: Processor timingPriority-1.
"activate the probe and evaluate the block"
Timer resume.
^ aBlock ensure: [
"Collect gc statistics"
SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
gcStats at: idx put: (gcVal - (gcStats at: idx))].
"cancel the probe and return the value"
Timer terminate.
time := Time millisecondClockValue - time0]!
Item was changed:
----- Method: SystemNavigation>>obsoleteClasses (in category 'query') -----
obsoleteClasses
"SystemNavigation default obsoleteClasses inspect"
"NOTE: Also try inspecting comments below"
+ | obs |
- | obs c |
obs := OrderedCollection new. Smalltalk garbageCollect.
Metaclass allInstancesDo:
+ [:m | | c |
+ c := m soleInstance.
- [:m | c := m soleInstance.
(c ~~ nil and: ['AnOb*' match: c name asString])
ifTrue: [obs add: c]].
^ obs asArray
"Likely in a ClassDict or Pool...
(Association allInstances select: [:a | (a value isKindOf: Class) and: ['AnOb*' match: a value name]]) asArray
"
"Obsolete class refs or super pointer in last lit of a method...
| n l found |
Smalltalk browseAllSelect:
[:m | found := false.
1 to: m numLiterals do:
[:i | (((l := m literalAt: i) isMemberOf: Association)
and: [(l value isKindOf: Behavior)
and: ['AnOb*' match: l value name]])
ifTrue: [found := true]].
found]
"!
Item was changed:
----- Method: Utilities class>>storeTextWindowContentsToFileNamed: (in category 'miscellaneous') -----
storeTextWindowContentsToFileNamed: aName
"Utilities storeTextWindowContentsToFileNamed: 'TextWindows'"
+ | windows aDict aRefStream |
- | windows aDict assoc aRefStream textToUse aTextView |
"there is a reference to World, but this method seems to be unused"
aDict := Dictionary new.
Smalltalk isMorphic
ifTrue:
[windows := World submorphs select: [:m | m isSystemWindow].
windows do:
+ [:w | | assoc |
+ assoc := w titleAndPaneText.
- [:w | assoc := w titleAndPaneText.
assoc ifNotNil:
[w holdsTranscript ifFalse:
[aDict add: assoc]]]]
ifFalse:
[windows := ScheduledControllers controllersSatisfying:
[:c | (c model isKindOf: StringHolder)].
windows do:
+ [:aController | | textToUse aTextView |
- [:aController |
aTextView := aController view subViews detect: [:m | m isKindOf: PluggableTextView] ifNone: [nil].
textToUse := aTextView
ifNil: [aController model contents]
ifNotNil: [aTextView controller text]. "The latest edits, whether accepted or not"
aDict at: aController view label put: textToUse]].
aDict size = 0 ifTrue: [^ self inform: 'no windows found to export.'].
aRefStream := ReferenceStream fileNamed: aName.
aRefStream nextPut: aDict.
aRefStream close.
self inform: 'Done!! ', aDict size printString, ' window(s) exported.'!
Item was changed:
----- Method: ChangeSet>>fileOutPSFor:on: (in category 'fileIn/Out') -----
fileOutPSFor: class on: stream
"Write out removals and initialization for this class."
+ | dict classRecord currentDef |
- | dict changeType classRecord currentDef |
classRecord := changeRecords at: class name ifAbsent: [^ self].
dict := classRecord methodChangeTypes.
dict keysSortedSafely do:
+ [:key | | changeType | changeType := dict at: key.
- [:key | changeType := dict at: key.
(#(remove addedThenRemoved) includes: changeType)
ifTrue: [stream nextChunkPut: class name,
' removeSelector: ', key storeString; cr]
ifFalse: [(key = #initialize and: [class isMeta]) ifTrue:
[stream nextChunkPut: class soleInstance name, ' initialize'; cr]]].
((classRecord includesChangeType: #change)
and: [(currentDef := class definition) ~= (self fatDefForClass: class)]) ifTrue:
[stream command: 'H3'; nextChunkPut: currentDef; cr; command: '/H3'].
(classRecord includesChangeType: #reorganize) ifTrue:
[class fileOutOrganizationOn: stream.
stream cr]!
Item was changed:
----- Method: ChangeSet>>convertToCurrentVersion:refStream: (in category 'converting') -----
convertToCurrentVersion: varDict refStream: smartRefStrm
"major change - 4/4/2000"
+
+ varDict at: 'classChanges' ifPresent: [ :x | | newish |
- | newish |
- varDict at: 'classChanges' ifPresent: [ :x |
newish := self convertApril2000: varDict using: smartRefStrm.
newish == self ifFalse: [^ newish].
].
^super convertToCurrentVersion: varDict refStream: smartRefStrm.
!
Item was changed:
----- Method: SystemNavigation>>allCallsOn: (in category 'query') -----
allCallsOn: aLiteral
"Answer a Collection of all the methods that call on aLiteral even deeply embedded in
literal array."
"self new browseAllCallsOn: #open:label:."
+ | aCollection special thorough byte |
- | aCollection special thorough aList byte |
aCollection := OrderedCollection new.
special := Smalltalk
hasSpecialSelector: aLiteral
ifTrueSetByte: [:b | byte := b].
thorough := (aLiteral isSymbol)
and: ["Possibly search for symbols imbedded in literal arrays"
Preferences thoroughSenders].
Cursor wait
showWhile: [self
+ allBehaviorsDo: [:class | | aList |
- allBehaviorsDo: [:class |
aList := thorough
ifTrue: [class
thoroughWhichSelectorsReferTo: aLiteral
special: special
byte: byte]
ifFalse: [class
whichSelectorsReferTo: aLiteral
special: special
byte: byte].
aList
do: [:sel | sel isDoIt
ifFalse: [aCollection
add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
^ aCollection!
Item was changed:
----- Method: MessageTally>>spyEvery:on: (in category 'initialize-release') -----
spyEvery: millisecs on: aBlock
"Create a spy and spy on the given block at the specified rate."
"Spy only on the active process (in which aBlock is run)"
+ | myDelay time0 observedProcess |
- | myDelay startTime time0 observedProcess |
aBlock isBlock
ifFalse: [self error: 'spy needs a block here'].
self class: aBlock receiver class method: aBlock method.
"set up the probe"
observedProcess _ Processor activeProcess.
myDelay := Delay forMilliseconds: millisecs.
time0 := Time millisecondClockValue.
gcStats := SmalltalkImage current getVMParameters.
+ Timer := [ | startTime |
- Timer := [
[true] whileTrue: [
startTime := Time millisecondClockValue.
myDelay wait.
self tally: Processor preemptedProcess suspendedContext
in: (ShowProcesses ifTrue: [
observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil]])
"tally can be > 1 if ran a long primitive"
by: (Time millisecondClockValue - startTime) // millisecs].
nil] newProcess.
Timer priority: Processor timingPriority-1.
"activate the probe and evaluate the block"
Timer resume.
^ aBlock ensure: [
"Collect gc statistics"
SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
gcStats at: idx put: (gcVal - (gcStats at: idx))].
"cancel the probe and return the value"
Timer ifNotNil: [ Timer terminate ].
time := Time millisecondClockValue - time0]!
Item was changed:
----- Method: ImageSegment class>>swapOutProjects (in category 'testing') -----
swapOutProjects "ImageSegment swapOutProjects"
"Swap out segments for all projects other than the current one."
+ | spaceLeft |
- | spaceLeft newSpaceLeft |
spaceLeft := Smalltalk garbageCollect.
Project allProjects doWithIndex:
+ [:p :i | | newSpaceLeft | p couldBeSwappedOut ifTrue:
- [:p :i | p couldBeSwappedOut ifTrue:
[Transcript cr; cr; nextPutAll: p name.
(ImageSegment new copyFromRoots: (Array with: p) sizeHint: 0)
extract; writeToFile: 'project' , i printString.
newSpaceLeft := Smalltalk garbageCollect.
Transcript cr; print: newSpaceLeft - spaceLeft; endEntry.
spaceLeft := newSpaceLeft]].!
Item was changed:
----- Method: SystemDictionary>>reformatChangesToUTF8 (in category 'housekeeping') -----
reformatChangesToUTF8
"Smalltalk reformatChangesToUTF8"
+ | f oldChanges |
- | f oldChanges classCount |
f := FileStream fileNamed: 'ST80.temp'.
f converter: (UTF8TextConverter new).
f header; timeStamp.
'Condensing Changes File...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
during:
+ [:bar | | classCount | classCount := 0.
- [:bar | classCount := 0.
Smalltalk allClassesDo:
[:class | bar value: (classCount := classCount + 1).
class moveChangesTo: f.
class putClassCommentToCondensedChangesFile: f.
class class moveChangesTo: f]].
SmalltalkImage current lastQuitLogPosition: f position.
f trailer; close.
oldChanges := SourceFiles at: 2.
oldChanges close.
FileDirectory default
deleteFileNamed: oldChanges name , '.old';
rename: oldChanges name toBe: oldChanges name , '.old';
rename: f name toBe: oldChanges name.
self setMacFileInfoOn: oldChanges name.
SourceFiles at: 2
put: (FileStream oldFileNamed: oldChanges name).
MultiByteFileStream codeConverterClass: UTF8TextConverter.
(SourceFiles at: 2) converter: (UTF8TextConverter new).
!
Item was changed:
----- Method: SystemNavigation>>hierarchyOfClassesSurrounding: (in category 'query') -----
hierarchyOfClassesSurrounding: aClass
"Answer a list of classes in the hierarchy both above and below the given class"
"SystemNavigation default hierarchyOfClassesSurrounding: StringHolder"
+ | list aClassNonMeta isMeta |
- | list aClassNonMeta isMeta theClassOrMeta |
aClass ifNil: [^ OrderedCollection new].
aClass ifNil: [^ self].
aClassNonMeta := aClass theNonMetaClass.
isMeta := aClassNonMeta ~~ aClass.
list := OrderedCollection new.
aClass allSuperclasses reverseDo:
[:cl | list addLast: cl].
aClassNonMeta allSubclassesWithLevelDo:
+ [:cl :level | | theClassOrMeta |
- [:cl :level |
theClassOrMeta := isMeta ifTrue: [cl class] ifFalse: [cl].
list addLast: theClassOrMeta]
startingLevel: 0.
^ list
!
Item was changed:
----- Method: Utilities class>>showFormsDictAcrossTopOfScreen: (in category 'graphical support') -----
showFormsDictAcrossTopOfScreen: formDict
"Display the given Dictionary of forms across the top of the screen, wrapping to subsequent lines if needed. Beneath each, put the name of the associated key."
"Utilities showFormsDictAcrossTopOfScreen: HaloIcons"
+ | screenBox position maxHeight ceiling |
- | position maxHeight screenBox ceiling elem box h labelWidth keyString |
position := 20.
maxHeight := 0.
ceiling := 0.
screenBox := Display boundingBox.
formDict associationsDo:
+ [:assoc | | box elem labelWidth keyString h |
+ (elem := assoc value) displayAt: (position @ ceiling).
- [:assoc | (elem := assoc value) displayAt: (position @ ceiling).
box := elem boundingBox.
h := box height.
keyString := (assoc key isString) ifTrue: [assoc key] ifFalse: [assoc key printString].
keyString displayAt: (position @ (ceiling + h)).
labelWidth := TextStyle default defaultFont widthOfString: keyString.
maxHeight := maxHeight max: h.
position := position + (box width max: labelWidth) + 5.
position > (screenBox right - 100) ifTrue:
[position := 20.
ceiling := ceiling + maxHeight + 15.
maxHeight := 0]]!
Item was changed:
----- Method: SystemNavigation>>allPrimitiveMethods (in category 'query') -----
allPrimitiveMethods
"Answer an OrderedCollection of all the methods that are implemented by primitives."
+ | aColl |
- | aColl method |
aColl := OrderedCollection new: 200.
Cursor execute
showWhile: [self allBehaviorsDo: [:class | class
+ selectorsDo: [:sel | | method |
- selectorsDo: [:sel |
method := class compiledMethodAt: sel.
method primitive ~= 0
ifTrue: [aColl addLast: class name , ' ' , sel , ' ' , method primitive printString]]]].
^ aColl!
Item was changed:
----- Method: Preferences class>>attemptToRestoreClassicFonts (in category 'fonts') -----
attemptToRestoreClassicFonts
"If certain fonts formerly used in early versions of Squeak happen to be present in the image, restore them to their corresponding roles. Not called by any other method -- intended to be invoked via do-it, possibly in a postscript"
"Preferences attemptToRestoreClassicFonts"
+
- | aTextStyle |
#( (setButtonFontTo: NewYork 12)
(setCodeFontTo: NewYork 12)
(setFlapsFontTo: ComicBold 16)
(setEToysFontTo: ComicBold 16)
(setListFontTo: NewYork 12)
(setMenuFontTo: NewYork 12)
(setWindowTitleFontTo: NewYork 15)
(setSystemFontTo: NewYork 12)) do:
+ [:triplet | | aTextStyle |
- [:triplet |
(aTextStyle := TextStyle named: triplet second) ifNotNil:
[self perform: triplet first with: (aTextStyle fontOfSize: triplet third).
Transcript cr; show: triplet second, ' installed as ', (triplet first copyFrom: 4 to: triplet first size - 3)]]!
Item was changed:
----- Method: ChangeSet>>summaryStringDelta: (in category 'fileIn/Out') -----
summaryStringDelta: delta
"Answer the string summarizing this changeSet"
+
- | ps s2 date author line intName |
^ String streamContents:
+ [:s | | line author s2 ps intName date |
- [:s |
intName := self name splitInteger.
intName first isNumber
ifTrue: [s nextPutAll: (intName first + delta) printString , intName last]
ifFalse: [s nextPutAll: intName first "weird convention of splitInteger"].
(ps := self preambleString)
ifNil: [s cr]
ifNotNil:
[s2 := ReadStream on: ps.
s2 match: 'Date:'; skipSeparators. date := s2 upTo: Character cr.
s2 match: 'Author:'; skipSeparators. author := s2 upTo: Character cr.
s nextPutAll: ' -- '; nextPutAll: author; nextPutAll: ' -- '; nextPutAll: date; cr.
[s2 atEnd] whileFalse:
[line := s2 upTo: Character cr.
(line isEmpty or: [line = '"']) ifFalse: [s nextPutAll: line; cr]]]].
!
Item was changed:
----- Method: SystemDictionary>>zapMVCprojects (in category 'shrinking') -----
zapMVCprojects
"Smalltalk zapMVCprojects"
+
- | window |
self flag: #bob. "zapping projects"
Smalltalk garbageCollect.
"So allInstances is precise"
Project
+ allSubInstancesDo: [:proj | | window | proj isTopProject
- allSubInstancesDo: [:proj | proj isTopProject
ifTrue: [proj isMorphic
ifFalse: ["Root project is MVC -- we must become the root"
Project current setParent: Project current.]]
ifFalse: [proj parent isMorphic
ifFalse: [proj isMorphic
ifTrue: ["Remove Morphic projects from MVC
views "
"... and add them back here."
window := (SystemWindow labelled: proj name)
model: proj.
window
addMorph: (ProjectViewMorph on: proj)
frame: (0 @ 0 corner: 1.0 @ 1.0).
window openInWorld.
proj setParent: Project current]].
proj isMorphic
ifFalse: ["Remove MVC projects from Morphic views"
Project deletingProject: proj]]]!
Item was changed:
----- Method: MessageTally>>rootPrintOn:total:totalTime:tallyExact:orThreshold: (in category 'printing') -----
rootPrintOn: aStream total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold
+ | groups sons |
- | sons groups p |
ShowProcesses ifFalse:[
^self treePrintOn: aStream
tabs: OrderedCollection new
thisTab: ''
total: total
totalTime: totalTime
tallyExact: isExact
orThreshold: threshold.
].
sons := isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold].
groups := sons groupBy:[:aTally| aTally process] having:[:g| true].
+ groups do:[:g| | p |
- groups do:[:g|
sons := g asSortedCollection.
p := g anyOne process.
"Do not show 'other processes' "
"Please keep consistency with #leavesInto:fromSender:
on showing them or not!!"
p ifNotNil: [
aStream nextPutAll: '--------------------------------'; cr.
aStream nextPutAll: 'Process: ', (p ifNil: [ 'other processes'] ifNotNil: [ p browserPrintString]); cr.
aStream nextPutAll: '--------------------------------'; cr.
(1 to: sons size) do:[:i |
(sons at: i)
treePrintOn: aStream
tabs: OrderedCollection new
thisTab: ''
total: total
totalTime: totalTime
tallyExact: isExact
orThreshold: threshold]].
].!
Item was changed:
----- Method: SmartRefStream class>>cleanUpCategories (in category 'initialize-release') -----
cleanUpCategories
+ | list valid removed |
- | list valid removed newList newVers |
"Look for all conversion methods that can't be used any longer. Delete them."
" SmartRefStream cleanUpCategories "
"Two part selectors that begin with convert and end with a digit."
"convertasossfe0: varDict asossfeu0: smartRefStrm"
list := Symbol selectorsContaining: 'convert'.
list := list select: [:symb | (symb beginsWith: 'convert') & (symb allButLast last isDigit)
ifTrue: [(symb numArgs = 2)]
ifFalse: [false]].
valid := 0. removed := 0.
list do: [:symb |
+ (self systemNavigation allClassesImplementing: symb) do: [:newClass | | newList newVers |
- (self systemNavigation allClassesImplementing: symb) do: [:newClass |
newList := (Array with: newClass classVersion), (newClass allInstVarNames).
newVers := self new versionSymbol: newList.
(symb endsWith: (':',newVers,':'))
ifFalse: [
"method is useless because can't convert to current shape"
newClass removeSelector: symb. "get rid of it"
removed := removed + 1]
ifTrue: [valid := valid + 1]]].
Transcript cr; show: 'Removed: '; print: removed;
show: ' Kept: '; print: valid; show: ' '.!
Item was changed:
----- Method: SmartRefStream>>checkFatalReshape: (in category 'import image segment') -----
checkFatalReshape: setOfClasses
+ | suspects |
- | suspects oldInstVars newInstVars bad className |
"Inform the user if any of these classes were reshaped. A block has a method from the old system whose receiver is of this class. The method's inst var references might be wrong. OK if inst vars were only added."
self flag: #bobconv.
setOfClasses isEmpty ifTrue: [^ self].
suspects := OrderedCollection new.
+ setOfClasses do: [:aClass | | newInstVars oldInstVars bad className |
- setOfClasses do: [:aClass |
className := renamed keyAtValue: aClass name ifAbsent: [aClass name].
oldInstVars := (structures at: className ifAbsent: [#(0)]) allButFirst. "should be there"
newInstVars := aClass allInstVarNames.
oldInstVars size > newInstVars size ifTrue: [bad := true].
oldInstVars size = newInstVars size ifTrue: [
bad := oldInstVars ~= newInstVars].
oldInstVars size < newInstVars size ifTrue: [
bad := oldInstVars ~= (newInstVars copyFrom: 1 to: oldInstVars size)].
bad ifTrue: [suspects add: aClass]].
suspects isEmpty ifFalse: [
self inform: ('Imported foreign methods will run on instances of:\',
suspects asArray printString,
'\whose shape has changed. Errors may occur.') withCRs].!
Item was changed:
----- Method: Preferences class>>installWindowColorsVia: (in category 'window colors') -----
installWindowColorsVia: colorSpecBlock
"Install windows colors using colorSpecBlock to deliver the color source for each element; the block is handed a WindowColorSpec object"
"Preferences installBrightWindowColors"
+
- | color |
self windowColorTable do:
+ [:aColorSpec | | color |
- [:aColorSpec |
color := (Color colorFrom: (colorSpecBlock value: aColorSpec)).
self setWindowColorFor: aColorSpec classSymbol to: color]
!
Item was changed:
----- Method: ChangeSet class>>fileOutChangeSetsNamed: (in category 'services') -----
fileOutChangeSetsNamed: nameList
"File out the list of change sets whose names are provided"
"ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')"
+ | notFound empty infoString |
- | notFound aChangeSet infoString empty |
notFound := OrderedCollection new.
empty := OrderedCollection new.
nameList do:
+ [:aName | | aChangeSet | (aChangeSet := self named: aName)
- [:aName | (aChangeSet := self named: aName)
ifNotNil:
[aChangeSet isEmpty
ifTrue:
[empty add: aName]
ifFalse:
[aChangeSet fileOut]]
ifNil:
[notFound add: aName]].
infoString := (nameList size - notFound size) printString, ' change set(s) filed out'.
notFound size > 0 ifTrue:
[infoString := infoString, '
', notFound size printString, ' change set(s) not found:'.
notFound do:
[:aName | infoString := infoString, '
', aName]].
empty size > 0 ifTrue:
[infoString := infoString, '
', empty size printString, ' change set(s) were empty:'.
empty do:
[:aName | infoString := infoString, '
', aName]].
self inform: infoString!
Item was changed:
----- Method: SystemNavigation>>methodHierarchyBrowserForClass:selector: (in category 'browse') -----
methodHierarchyBrowserForClass: aClass selector: sel
"Create and schedule a message set browser on all implementors of the
currently selected message selector. Do nothing if no message is selected."
"SystemNavigation default
methodHierarchyBrowserForClass: ParagraphEditor
selector: #isControlActive"
+ | list aClassNonMeta isMeta tab |
- | list tab stab aClassNonMeta isMeta theClassOrMeta |
aClass ifNil: [^ self].
aClass isTrait ifTrue: [^ self].
sel ifNil: [^ self].
aClassNonMeta := aClass theNonMetaClass.
isMeta := aClassNonMeta ~~ aClass.
list := OrderedCollection new.
tab := ''.
aClass allSuperclasses reverseDo:
[:cl |
(cl includesSelector: sel) ifTrue:
[list addLast: tab , cl name, ' ', sel].
tab := tab , ' '].
aClassNonMeta allSubclassesWithLevelDo:
+ [:cl :level | | theClassOrMeta stab |
- [:cl :level |
theClassOrMeta := isMeta ifTrue: [cl class] ifFalse: [cl].
(theClassOrMeta includesSelector: sel) ifTrue:
[stab := ''. 1 to: level do: [:i | stab := stab , ' '].
list addLast: tab , stab , theClassOrMeta name, ' ', sel]]
startingLevel: 0.
self browseMessageList: list name: 'Inheritance of ' , sel
!
Item was changed:
----- Method: TextDiffBuilder>>validateRuns: (in category 'creating patches') -----
validateRuns: runList
+ | srcPosCopy dstPosCopy |
- | srcPosCopy dstPosCopy lines srcIndex dstIndex |
srcPosCopy := srcPos copy.
srcPosCopy associationsDo:[:assoc| assoc value: assoc value asSet].
dstPosCopy := dstPos copy.
dstPosCopy associationsDo:[:assoc| assoc value: assoc value asSet].
+ runList associationsDo:[:assoc| | dstIndex lines srcIndex |
- runList associationsDo:[:assoc|
srcIndex := assoc key y.
dstIndex := assoc key x.
lines := assoc value.
lines do:[:string|
(srcPosCopy at: string) remove: srcIndex.
(dstPosCopy at: string) remove: dstIndex.
srcIndex := srcIndex + 1.
dstIndex := dstIndex + 1.
].
].
removed := OrderedCollection new.
srcPosCopy associationsDo:[:assoc|
assoc value do:[:index| removed add: (index -> assoc key)].
].
removed := removed sortBy:[:a1 :a2| a1 key < a2 key].
added := OrderedCollection new.
dstPosCopy associationsDo:[:assoc|
assoc value do:[:index| added add: (index -> assoc key)].
].
added := added sortBy:[:a1 :a2| a1 key < a2 key].
!
Item was changed:
----- Method: SystemNavigation>>unimplemented (in category 'query') -----
unimplemented
"Answer an Array of each message that is sent by an expression in a method but is not implemented by any object in the system."
+ | all unimplemented |
- | all unimplemented entry |
all := IdentitySet new: Symbol instanceCount * 2.
Cursor wait showWhile:
[self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | all add: aSelector]]].
unimplemented := IdentityDictionary new.
Cursor execute showWhile: [
self allBehaviorsDo: [:cl |
cl selectorsDo: [:sel |
+ (cl compiledMethodAt: sel) messages do: [:m | | entry |
- (cl compiledMethodAt: sel) messages do: [:m |
(all includes: m) ifFalse: [
entry := unimplemented at: m ifAbsent: [Array new].
entry := entry copyWith: (cl name, '>', sel).
unimplemented at: m put: entry]]]]].
^ unimplemented
!
Item was changed:
----- Method: ImageSegment>>prepareToBeSaved (in category 'fileIn/Out') -----
prepareToBeSaved
"Prepare objects in outPointers to be written on the disk. They must be able to match up with existing objects in their new system. outPointers is already a copy.
Classes are already converted to a DiskProxy.
Associations in outPointers:
1) in Smalltalk.
2) in a classPool.
3) in a shared pool.
4) A pool dict pointed at directly"
+ | left myClasses outIndexes |
- | left pool myClasses outIndexes key |
myClasses := Set new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]].
outIndexes := IdentityDictionary new.
+ outPointers withIndexDo: [:anOut :ind | | key |
- outPointers withIndexDo: [:anOut :ind |
anOut isVariableBinding ifTrue: [
(myClasses includes: anOut value)
ifFalse: [outIndexes at: anOut put: ind]
ifTrue: [(Smalltalk associationAt: anOut key ifAbsent: [3]) == anOut
ifTrue: [outPointers at: ind put:
(DiskProxy global: #Smalltalk selector: #associationDeclareAt:
args: (Array with: anOut key))]
ifFalse: [outIndexes at: anOut put: ind]
]].
(anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly"
(key := Smalltalk keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [
outPointers at: ind put:
(DiskProxy global: key selector: #yourself args: #())]].
anOut isMorph ifTrue: [outPointers at: ind put:
(StringMorph contents: anOut printString, ' that was not counted')]
].
left := outIndexes keys asSet.
left size > 0 ifTrue: ["Globals"
(left copy) do: [:assoc | "stay stable while delete items"
(Smalltalk associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
outPointers at: (outIndexes at: assoc) put:
(DiskProxy global: #Smalltalk selector: #associationAt:
args: (Array with: assoc key)).
left remove: assoc]]].
left size > 0 ifTrue: ["Class variables"
Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [
(left copy) do: [:assoc | "stay stable while delete items"
(cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
outPointers at: (outIndexes at: assoc) put:
(DiskProxy new global: cls name
preSelector: #classPool
selector: #associationAt:
args: (Array with: assoc key)).
left remove: assoc]]]]].
left size > 0 ifTrue: ["Pool variables"
+ Smalltalk associationsDo: [:poolAssoc | | pool |
- Smalltalk associationsDo: [:poolAssoc |
poolAssoc value class == Dictionary ifTrue: ["a pool"
pool := poolAssoc value.
(left copy) do: [:assoc | "stay stable while delete items"
(pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
outPointers at: (outIndexes at: assoc) put:
(DiskProxy global: poolAssoc key selector: #associationAt:
args: (Array with: assoc key)).
left remove: assoc]]]]].
left size > 0 ifTrue: [
"If points to class in arrayOfRoots, must deal with it separately"
"OK to have obsolete associations that just get moved to the new system"
self inform: 'extra associations'.
left inspect].
!
Item was changed:
----- Method: Utilities class>>garbageCollectAndReport (in category 'miscellaneous') -----
garbageCollectAndReport
"Do a garbage collection, and report results to the user."
+ | reportString |
- | cc reportString |
reportString := String streamContents:
[:aStream |
aStream nextPutAll: Smalltalk bytesLeftString.
Smalltalk at: #Command ifPresent:
+ [:cmdClass | | cc |
- [:cmdClass |
(cc := cmdClass instanceCount) > 0 ifTrue:
[aStream cr; nextPutAll:
('(note: there are ', cc printString,
' undo record(s) present in your
system; purging them may free up more space.)')]]].
self inform: reportString
!
Item was changed:
----- Method: TextDiffBuilder>>processShiftedRuns (in category 'creating patches') -----
processShiftedRuns
+
- | key |
shifted isNil ifTrue:[^self].
+ shifted do:[:assoc| | key |
- shifted do:[:assoc|
key := assoc key.
assoc value doWithIndex:[:line :idx|
removed add: (key y + idx - 1) -> line.
added add: (key x + idx - 1) -> line].
runs removeKey: assoc key.
].
!
Item was changed:
----- Method: Utilities class>>readServer:special:updatesThrough:saveLocally:updateImage: (in category 'fetching updates') -----
readServer: serverList special: indexPrefix updatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage
"Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load. This makes it possible to update only up to a particular point. If saveLocally is true, then save local copies of the update files on disc. If updateImage is true, then absorb the updates into the current image."
"Utilities readServer: Utilities serverUrls updatesThrough: 828 saveLocally: true updateImage: true"
+ | str urls failed loaded |
+ Cursor wait showWhile: [ | docQueue docQueueSema |
- | urls failed loaded docQueue this nextDoc docQueueSema str updateName |
- Cursor wait showWhile: [
urls := self newUpdatesOn: (serverList collect: [:url | url, 'updates/'])
special: indexPrefix
throughNumber: maxNumber.
loaded := 0.
failed := nil.
"send downloaded documents throuh this queue"
docQueue := SharedQueue new.
"this semaphore keeps too many documents from beeing queueed up at a time"
docQueueSema := Semaphore new.
5 timesRepeat: [ docQueueSema signal ].
"fork a process to download the updates"
self retrieveUrls: urls ontoQueue: docQueue withWaitSema: docQueueSema.
"process downloaded updates in the foreground"
+ 'Processing updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar | | nextDoc this updateName |
- 'Processing updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar |
[ this := docQueue next.
nextDoc := docQueue next.
nextDoc = #failed ifTrue: [ failed := this ].
(failed isNil and: [ nextDoc ~= #finished ])
] whileTrue: [
failed ifNil: [
nextDoc reset; text.
nextDoc size = 0 ifTrue: [ failed := this ]. ].
failed ifNil: [
nextDoc peek asciiValue = 4 "pure object file"
ifTrue: [failed := this]]. "Must be fileIn, not pure object file"
failed ifNil: [
"(this endsWith: '.html') ifTrue: [doc := doc asHtml]."
"HTML source code not supported here yet"
updateImage
ifTrue: [
updateName := (this findTokens: '/') last.
ChangeSet newChangesFromStream: nextDoc named: updateName.
SystemVersion current registerUpdate: updateName initialIntegerOrNil].
saveLocally ifTrue:
[self saveUpdate: nextDoc onFile: (this findTokens: '/') last]. "if wanted"
loaded := loaded + 1.
bar value: loaded].
docQueueSema signal].
]].
failed ~~ nil & (urls size - loaded > 0) ifTrue: [
str := loaded printString ,' new update file(s) processed.'.
str := str, '\Could not load ' withCRs,
(urls size - loaded) printString ,' update file(s).',
'\Starting with "' withCRs, failed, '".'.
self inform: str].
^ Array with: failed with: loaded
!
Item was changed:
----- Method: Project>>writeStackText:in:registerIn: (in category 'file in/out') -----
writeStackText: stacks in: resourceDirectory registerIn: aCollector
"The user's text is very valuable. Write an extra file with just the text. It can be read in case the Project can't be opened."
"Find allText for each stack, storeOn a local file in the resources folder, with a name like myProj.005.myStack.t. Make the names be unique."
"get project name and version"
+ | resourceURL ind |
- | localName sn trial char ind fs resourceURL textLoc |
resourceURL := self resourceUrl.
+ stacks do: [:stackObj | | sn localName char trial textLoc fs | "Construct a good file name"
- stacks do: [:stackObj | "Construct a good file name"
localName := self versionedFileName allButLast: 2. "projectName.005."
stacks size = 1 ifFalse: ["must distinguish between stacks in the project"
(sn := stackObj knownName) ifNil: [
sn := stackObj hash printString]. "easy name, or use hash"
localName := localName , sn, FileDirectory dot]. "projectName.005.myStack."
localName := localName , 't'.
"See if in use because truncates same as another, fix last char, try again"
[trial := resourceDirectory checkName: localName fixErrors: true.
trial endsWith: '.t'] whileFalse: [
localName := (localName allButLast: 3) , FileDirectory dot, 't'].
[resourceDirectory fileExists: trial] whileTrue: [
char := trial at: (ind := trial size - 3).
trial at: ind put: (char asciiValue + 1) asCharacter]. "twiddle it a little"
"write allText in file"
fs := resourceDirectory newFileNamed: trial.
fs timeStamp; cr; nextPutAll: '''This is the text for a stack in this project. Use only in an emergency, if the project file is ever unreadable.''.'; cr; cr.
stackObj getAllText storeOn: fs. fs close.
textLoc := (ResourceLocator new) localFileName: trial;
urlString: resourceURL, '/', trial.
aCollector locatorMap at: trial "any distinct object" put: textLoc.
].!
Item was changed:
----- Method: SmartRefStream>>restoreClassInstVars (in category 'read write') -----
restoreClassInstVars
"Install the values of the class instance variables of UniClasses
(i.e. scripts slotInfo). classInstVars is ((#Player25 scripts slotInfo)
...). Thank you Mark Wai for the bug fix."
+ | normal trans |
- | normal aName newName newCls trans rList start |
self flag: #bobconv.
self moreObjects ifFalse: [^ self]. "are no UniClasses with class inst vars"
classInstVars := super next. "Array of arrays"
normal := Object class instSize. "might give trouble if Player class superclass changes size"
(structures at: #Player ifAbsent: [#()]) = #(0 'dependents' 'costume') ifTrue:
[trans := 1]. "now (0 costume costumes). Do the conversion of Player class
inst vars in Update 509."
+ classInstVars do: [:list | | aName newCls rList newName start |
- classInstVars do: [:list |
aName := (list at: 1) asSymbol.
rList := list.
newName := renamed at: aName ifAbsent: [aName].
newCls := Smalltalk at: newName
ifAbsent: [self error: 'UniClass definition missing'].
("old conversion" trans == 1 and: [newCls inheritsFrom: Player]) ifTrue: [
"remove costumeDictionary from Player class inst vars"
rList := rList asOrderedCollection.
rList removeAt: 4]. "costumeDictionary's value"
start := list second = 'Update to read classPool' ifTrue: [4] ifFalse: [2].
newCls class instSize = (normal + (rList size) - start + 1) ifFalse:
[self error: 'UniClass superclass class has changed size'].
"Need to install a conversion method mechanism"
start = 4 ifTrue: [newCls instVarAt: normal - 1 "classPool" put: (list at: 3)].
start to: rList size do: [:ii |
newCls instVarAt: normal + ii - start + 1 put: (rList at: ii)]].
!
Item was changed:
----- Method: ImageSegment>>findRogueRootsPrep (in category 'testing') -----
findRogueRootsPrep
"Part of the tool to track down unwanted pointers into the segment. Break all owner pointers in submorphs, scripts, and viewers in flaps."
+ | wld players morphs |
- | wld players morphs scriptEditors |
wld := arrayOfRoots detect: [:obj |
obj isMorph ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil].
wld ifNil: [wld := arrayOfRoots detect: [:obj | obj isMorph]
ifNone: [^ self error: 'can''t find a root morph']].
morphs := IdentitySet new: 400.
wld allMorphsAndBookPagesInto: morphs.
players := wld presenter allExtantPlayers. "just the cached list"
+ players do: [:pp | | scriptEditors |
- players do: [:pp |
scriptEditors := pp class tileScriptNames collect: [:nn |
pp scriptEditorFor: nn].
scriptEditors do: [:se | morphs addAll: se allMorphs]].
wld submorphs do: [:mm | "non showing flaps"
(mm isKindOf: FlapTab) ifTrue: [
mm referent allMorphsAndBookPagesInto: morphs]].
morphs do: [:mm | "break the back pointers"
mm isInMemory ifTrue: [
(mm respondsTo: #target) ifTrue: [
mm nearestOwnerThat: [:ow | ow == mm target
ifTrue: [mm target: nil. true]
ifFalse: [false]]].
(mm respondsTo: #arguments) ifTrue: [
mm arguments do: [:arg | arg ifNotNil: [
mm nearestOwnerThat: [:ow | ow == arg
ifTrue: [mm arguments at: (mm arguments indexOf: arg) put: nil. true]
ifFalse: [false]]]]].
mm eventHandler ifNotNil: ["recipients point back up"
(morphs includesAllOf: (mm eventHandler allRecipients)) ifTrue: [
mm eventHandler: nil]].
"temporary, until using Model for PartsBin"
(mm isMorphicModel) ifTrue: [
(mm model isMorphicModel) ifTrue: [
mm model breakDependents]].
(mm isTextMorph) ifTrue: [mm setContainer: nil]]].
(Smalltalk includesKey: #Owners) ifTrue: [Smalltalk at: #Owners put: nil].
"in case findOwnerMap: is commented out"
"self findOwnerMap: morphs."
morphs do: [:mm | "break the back pointers"
mm isInMemory ifTrue: [mm privateOwner: nil]].
"more in extensions?"
!
Item was changed:
----- Method: ChangeSet>>convertApril2000:using: (in category 'converting') -----
convertApril2000: varDict using: smartRefStrm
+ | classChanges methodChanges methodRemoves classRemoves cls info |
- | cls info selector pair classChanges methodChanges methodRemoves classRemoves |
"These variables are automatically stored into the new instance:
('name' 'preamble' 'postscript' 'structures' 'superclasses' ).
This method is for additional changes.
It initializes the isolation variables, and then duplicates the logic fo
assimilateAllChangesFoundIn:."
revertable := false.
isolationSet := nil.
isolatedProject := nil.
changeRecords := Dictionary new.
classChanges := varDict at: 'classChanges'.
classChanges keysDo:
[:className |
(cls := Smalltalk classNamed: className) ifNotNil:
[info := classChanges at: className ifAbsent: [Set new].
info do: [:each | self atClass: cls add: each]]].
methodChanges := varDict at: 'methodChanges'.
methodRemoves := varDict at: 'methodRemoves'.
methodChanges keysDo:
[:className |
(cls := Smalltalk classNamed: className) ifNotNil:
[info := methodChanges at: className ifAbsent: [Dictionary new].
info associationsDo:
+ [:assoc | | selector pair | selector := assoc key.
- [:assoc | selector := assoc key.
(assoc value == #remove or: [assoc value == #addedThenRemoved])
ifTrue:
[assoc value == #addedThenRemoved
ifTrue: [self atSelector: selector class: cls put: #add].
pair := methodRemoves at: {cls name. selector} ifAbsent: [nil] .
self removeSelector: selector class: cls priorMethod: nil lastMethodInfo: pair]
ifFalse:
[self atSelector: selector class: cls put: assoc value]]]].
classRemoves := varDict at: 'classRemoves'.
classRemoves do:
[:className | self noteRemovalOf: className].
!
Item was changed:
----- Method: SARInstaller>>fileInFrom: (in category 'fileIn') -----
fileInFrom: stream
"The zip has been saved already by the download.
Read the zip into my instvar, then file in the correct members"
+
- | preamble postscript |
+ [ | postscript preamble |
- [
stream position: 0.
zip := ZipArchive new readFrom: stream.
preamble := zip memberNamed: 'install/preamble'.
preamble ifNotNil: [
preamble contentStream text setConverterForCode fileInFor: self announcing: 'Preamble'.
self class currentChangeSet preambleString: preamble contents.
].
postscript := zip memberNamed: 'install/postscript'.
postscript ifNotNil: [
postscript contentStream text setConverterForCode fileInFor: self announcing: 'Postscript'.
self class currentChangeSet postscriptString: postscript contents.
].
preamble isNil & postscript isNil ifTrue: [
(self confirm: 'No install/preamble or install/postscript member were found.
Install all the members automatically?') ifTrue: [ self installAllMembers ]
].
] ensure: [ stream close ].
!
Item was changed:
----- Method: Preferences class>>registerForEvents (in category 'dynamic preferences') -----
registerForEvents
"Preferences registerForEvents"
+
- | aPrefSymbol aPreference |
SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self.
SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #prefEvent:.
Smalltalk allClassesDo:[:aClass|
aClass class methodsDo:[:method|
+ method pragmas do:[:pragma| | aPreference aPrefSymbol |
- method pragmas do:[:pragma|
pragma keyword == #preference:category:description:type: ifTrue:[
aPrefSymbol := (aClass name,'>>', method selector) asSymbol.
aPreference := self
preference: pragma arguments first
category: pragma arguments second
description: pragma arguments third
type: pragma arguments fourth.
aPreference
provider: aClass
getter: method selector
setter: method selector asMutator.
self dictionaryOfPreferences at: aPrefSymbol put: aPreference]]]].
!
Item was changed:
----- Method: ImageSegment>>findRogueRootsRefStrm: (in category 'testing') -----
findRogueRootsRefStrm: rootArray
"This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment.
1) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream. Put in a Set.
2) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment."
+ | goodInSeg inSeg pointIn dummy |
- | dummy goodInSeg inSeg ok pointIn |
dummy := ReferenceStream on: (DummyStream on: nil).
"Write to a fake Stream, not a file"
rootArray do:
[:root |
dummy rootObject: root. "inform him about the root"
dummy nextPut: root].
inSeg := dummy references keys asSet.
dummy := nil.
Smalltalk garbageCollect. "dump refs dictionary"
rootArray do: [:each | inSeg remove: each ifAbsent: []].
"want them to be pointed at from outside"
pointIn := IdentitySet new: 500.
goodInSeg := IdentitySet new: 2000.
inSeg do:
+ [:obj | | ok |
- [:obj |
ok := obj class isPointers.
obj class == Color ifTrue: [ok := false].
obj class == TranslucentColor ifTrue: [ok := false].
obj class == Array ifTrue: [obj size = 0 ifTrue: [ok := false]].
"shared #() in submorphs of all Morphs"
ok ifTrue: [goodInSeg add: obj]].
goodInSeg
do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: #())].
inSeg do: [:each | pointIn remove: each ifAbsent: []].
rootArray do: [:each | pointIn remove: each ifAbsent: []].
pointIn remove: inSeg array ifAbsent: [].
pointIn remove: goodInSeg array ifAbsent: [].
pointIn remove: pointIn array ifAbsent: [].
self halt: 'Examine local variables pointIn and inSeg'.
^pointIn!
Item was changed:
----- Method: SystemNavigation>>allReferencesToPool:from: (in category 'query') -----
allReferencesToPool: aPool from: aClass
"Answer all the references to variables from aPool"
+ | list |
- | ref list |
list := OrderedCollection new.
aClass withAllSubclassesDo:[:cls|
+ cls selectorsAndMethodsDo:[:sel :meth| | ref |
- cls selectorsAndMethodsDo:[:sel :meth|
ref := meth literals detect:[:lit|
lit isVariableBinding and:[(aPool bindingOf: lit key) notNil]
] ifNone:[nil].
ref ifNotNil:[
list add:(MethodReference new setStandardClass: cls methodSymbol: sel)
].
].
].
^list!
Item was changed:
----- Method: Utilities class>>fixUpProblemsWithAllCategory (in category 'miscellaneous') -----
fixUpProblemsWithAllCategory
"Moves all methods that are in formally classified a category named '-- all --' into the default 'as yet unclassified' category"
"Utilities fixUpProblemsWithAllCategory"
+ | methodCount classCount |
- | org aCategory methodCount classCount any |
self flag: #ShouldBeMovedInClassOrganization.
methodCount := 0.
classCount := 0.
self systemNavigation allBehaviorsDo:
+ [:aClass | | org any | org := aClass organization.
- [:aClass | org := aClass organization.
(org categories includes: #'-- all --') ifTrue:
[any := false.
aClass selectorsDo:
+ [:aSelector | | aCategory |
- [:aSelector |
aCategory := org categoryOfElement: aSelector.
aCategory = #'-- all --' ifTrue:
[org classify: aSelector under: ClassOrganizer default suppressIfDefault: false.
Transcript cr; show: aClass name, ' >> ', aSelector.
methodCount := methodCount + 1.
any := true]].
any ifTrue: [classCount := classCount + 1].
org removeEmptyCategories]].
Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved from "-- all --" to "as yet unclassified"'
!
Item was changed:
----- Method: ImageSegment>>reshapeClasses:refStream: (in category 'fileIn/Out') -----
reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
+ | bads allVarMaps partials in out perfect |
- | bads allVarMaps perfect insts partials in out |
self flag: #bobconv.
partials := OrderedCollection new.
bads := OrderedCollection new.
allVarMaps := IdentityDictionary new.
+ mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass | | insts |
- mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass |
(theRealClass indexIfCompact > 0) "and there is a fake class"
ifFalse: [insts := aFakeClass allInstances]
ifTrue: ["instances have the wrong class. Fix them before anyone notices."
insts := OrderedCollection new.
self allObjectsDo: [:obj | obj class == theRealClass ifTrue: [insts add: obj]].
].
insts do: [ :misShapen |
perfect := smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps.
bads
detect: [ :x | x == misShapen]
ifNone: [
bads add: misShapen.
partials add: perfect
].
].
].
bads isEmpty ifFalse: [
bads asArray elementsForwardIdentityTo: partials asArray
].
in := OrderedCollection new.
out := OrderedCollection new.
partials do: [ :each |
perfect := smartRefStream convert2: each allVarMaps: allVarMaps.
in
detect: [ :x | x == each]
ifNone: [
in add: each.
out add: perfect
]
].
in isEmpty ifFalse: [
in asArray elementsForwardIdentityTo: out asArray
].
!
Item was changed:
----- Method: Utilities class>>newUpdatesOn:special:throughNumber: (in category 'fetching updates') -----
newUpdatesOn: serverList special: indexPrefix throughNumber: aNumber
"Return a list of fully formed URLs of update files we do not yet have. Go to the listed servers and look at the file 'updates.list' for the names of the last N update files. We look backwards for the first one we have, and make the list from there. tk 9/10/97
No updates numbered higher than aNumber (if it is not nil) are returned "
+ | existing out maxNumber |
- | existing doc list out ff raw char maxNumber itsNumber |
maxNumber := aNumber ifNil: [99999].
out := OrderedCollection new.
existing := SystemVersion current updates.
+ serverList do: [:server | | raw doc list char |
- serverList do: [:server |
doc := HTTPClient httpGet: 'http://' , server,indexPrefix,'updates.list'.
"test here for server being up"
doc class == RWBinaryOrTextStream ifTrue:
[raw := doc reset; contents. "one file name per line"
list := self extractThisVersion: raw.
+ list reverseDo: [:fileName | | ff itsNumber |
- list reverseDo: [:fileName |
ff := (fileName findTokens: '/') last. "allow subdirectories"
itsNumber := ff initialIntegerOrNil.
(existing includes: itsNumber)
ifFalse:
[
(itsNumber == nil or: [itsNumber <= maxNumber])
ifTrue:
[out addFirst: 'http://' , server, fileName]]
ifTrue: [^ out]].
((out size > 0) or: [char := doc reset; skipSeparators; next.
(char == $*) | (char == $#)]) ifTrue:
[^ out "we have our list"]]. "else got error msg instead of file"
"Server was down, try next one"].
self inform: 'All code update servers seem to be unavailable'.
^ out!
Item was changed:
----- Method: Project>>buildJumpToMenu: (in category 'utilities') -----
buildJumpToMenu: menu
"Make the supplied menu offer a list of potential projects, consisting of:
* The previous-project chain
* The next project, if any
* The parent project, if any
* All projects, alphabetically or hierarchically"
+ | prev listed i next |
- | prev listed i next toAdd |
listed := OrderedCollection with: self.
i := 0.
"The previous Project chain"
prev := self previousProject.
[(prev ~~ nil and: [(listed includes: prev) not])] whileTrue:
[i := i + 1.
listed add: prev.
self addItem: prev name , ' (', ('back {1}' translated format:{i} ), ')'
toMenu: menu
selection: ('%back' , i printString)
project: prev.
prev := prev previousProject].
i > 0 ifTrue: [menu addLine].
"Then the next Project"
(((next := self nextProject) ~~ nil) and: [(listed includes: next) not]) ifTrue:
[self addItem: (next name, ' (', ('forward {1}' translated format:{1}), ')')
toMenu: menu
selection: next name
project: next].
next ~~ nil ifTrue: [menu addLine].
"Then the parent"
self isTopProject ifFalse:
[self addItem: self parent name , ' (', 'parent' translated, ')'
toMenu: menu
selection: #parent
project: self parent.
menu addLine].
"Finally all the projects, in hierarchical or alphabetical order:"
(Preferences alphabeticalProjectMenu
ifTrue:
[Project allNamesAndProjects]
ifFalse:
[Project hierarchyOfNamesAndProjects]) do:
+ [:aPair | | toAdd |
- [:aPair |
toAdd := aPair last isCurrentProject
ifTrue:
[aPair first, ' (', 'current' translated, ')']
ifFalse:
[aPair first].
self addItem: toAdd
toMenu: menu
selection: aPair first
project: aPair last].
^ menu!
Item was changed:
----- Method: MessageTally>>printSenderCountsOn: (in category 'printing') -----
printSenderCountsOn: aStream
+ | mergedSenders |
- | mergedSenders mergedNode |
mergedSenders := IdentityDictionary new.
senders do:
+ [:node | | mergedNode |
- [:node |
mergedNode := mergedSenders at: node method ifAbsent: [nil].
mergedNode == nil
ifTrue: [mergedSenders at: node method put: node]
ifFalse: [mergedNode bump: node tally]].
mergedSenders asSortedCollection do:
[:node |
10 to: node tally printString size by: -1 do: [:i | aStream space].
node printOn: aStream total: tally totalTime: nil tallyExact: true]!
Item was changed:
----- Method: ChangeSet>>methodsWithAnyInitialsOtherThan: (in category 'moving changes') -----
methodsWithAnyInitialsOtherThan: myInits
"Return a collection of method refs whose author appears to be different from the given one, even historically"
+ | slips |
- | slips method aTimeStamp |
slips := Set new.
self changedClasses do: [:aClass |
+ (self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc | | method |
- (self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc |
(#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
[method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
method ifNotNil: [
+ (aClass changeRecordsAt: mAssoc key) do: [ :chg | | aTimeStamp |
- (aClass changeRecordsAt: mAssoc key) do: [ :chg |
aTimeStamp := chg stamp.
(aTimeStamp notNil and: [(aTimeStamp beginsWith: myInits) not])
ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]].
^ slips!
Item was changed:
----- Method: Utilities class>>reportSenderCountsFor: (in category 'investigations') -----
reportSenderCountsFor: selectorList
"Produce a report on the number of senders of each of the selectors in
the list. 1/27/96 sw"
+ | total report |
- | total report thisSize |
total := 0.
report := '
'.
selectorList
+ do: [:selector | | thisSize |
- do: [:selector |
thisSize := (self systemNavigation allCallsOn: selector) size.
report := report , thisSize printString , String tab , selector printString , String cr.
total := total + thisSize].
report := report , '--- ------------------
'.
report := report , total printString , String tab , 'TOTAL
'.
^ report!
Item was changed:
----- Method: SystemDictionary>>writeImageSegmentsFrom:withKernel: (in category 'shrinking') -----
writeImageSegmentsFrom: segmentDictionary withKernel: kernel
"segmentDictionary is associates segmentName -> {classNames. methodNames},
and kernel is another set of classNames determined to be essential.
Add a partition, 'Secondary' with everything not in partitions and not in the kernel.
Then write segments based on this partitioning of classes."
+ | secondary dups segDict overlaps symbolHolder classes |
- | metas secondary dups segDict overlaps classes n symbolHolder |
"First, put all classes that are in no other partition, and not in kernel into a new partition called 'Secondary'. Also remove any classes in kernel from putative partitions."
secondary := Smalltalk classNames asIdentitySet.
segmentDictionary keysDo:
[:segName |
secondary removeAllFoundIn: (segmentDictionary at: segName) first.
(segmentDictionary at: segName) first removeAllFoundIn: kernel].
secondary removeAllFoundIn: kernel.
secondary removeAllFoundIn: #(PseudoContext TranslatedMethod Utilities Preferences OutOfScopeNotification FakeClassPool BlockCannotReturn FormSetFont ExternalSemaphoreTable NetNameResolver ScreenController InterpreterPlugin Command WeakSet).
FileDirectory allSubclassesDo: [:c | secondary remove: c name ifAbsent: []].
segmentDictionary at: 'Secondary' put: {secondary. {}}.
"Now build segDict giving className -> segName, and report any duplicates."
dups := Dictionary new.
segDict := IdentityDictionary new: 3000.
segmentDictionary keysDo:
[:segName | (segmentDictionary at: segName) first do:
[:className |
(segDict includesKey: className) ifTrue:
[(dups includesKey: className) ifFalse: [dups at: className put: Array new].
dups at: className put: (dups at: className) , {segName}].
segDict at: className put: segName]].
dups size > 0 ifTrue: [dups inspect. ^ self error: 'Duplicate entries'].
"Then for every class in every partition, make sure that neither it
nor any of its superclasses are in any other partition. If they are,
enter them in a dictionary of overlaps.
If the dictionary is not empty, then stop and report it."
overlaps := Dictionary new.
segmentDictionary keysDo:
[:segName |
classes := (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
classes do:
[:c | (c isKindOf: Class) ifTrue:
[c withAllSuperclasses do:
+ [:sc | | n | n := segDict at: sc name ifAbsent: [segName].
- [:sc | n := segDict at: sc name ifAbsent: [segName].
n ~= segName ifTrue:
[n = 'Secondary'
ifTrue: [(segmentDictionary at: 'Secondary') first
remove: sc name ifAbsent: []]
ifFalse: [overlaps at: c name put:
(c withAllSuperclasses collect: [:cc | segDict associationAt: cc name ifAbsent: [cc name -> 'Kernel']])]]]]]].
overlaps size > 0 ifTrue: [overlaps inspect. ^ self error: 'Superclasses in separate segments'].
"If there are no overlaps, then proceed to write the partitioned classes."
symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers,
so they will be in outPointers"
segmentDictionary keysDo:
[:segName | Utilities informUser: segName during:
+ [ | metas |classes := (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
- [classes := (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
metas := classes select: [:c | c isKindOf: Class] thenCollect: [:c | c class].
(ImageSegment new copyFromRoots: classes , metas sizeHint: 0) extract;
writeToFile: segName]].
symbolHolder. "Keep compiler for getting uppity."!
Item was changed:
----- Method: SystemNavigation>>browseClassVarRefs: (in category 'browse') -----
browseClassVarRefs: aClass
"Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods
that refer to the selected class variable"
+ | lines labelStream allVars index owningClasses |
- | lines labelStream vars allVars index owningClasses |
lines := OrderedCollection new.
allVars := OrderedCollection new.
owningClasses := OrderedCollection new.
labelStream := WriteStream on: (String new: 200).
aClass withAllSuperclasses reverseDo:
+ [:class | | vars |
- [:class |
vars := class classVarNames.
vars do:
[:var |
labelStream nextPutAll: var; cr.
allVars add: var.
owningClasses add: class].
vars isEmpty ifFalse: [lines add: allVars size]].
labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better"
labelStream skip: -1 "cut last CR".
index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines).
index = 0 ifTrue: [^ self].
self browseAllCallsOn:
((owningClasses at: index) classPool associationAt: (allVars at: index))!
Item was changed:
----- Method: ChangeSet>>askRenames:addTo:using: (in category 'fileIn/Out') -----
askRenames: renamed addTo: msgSet using: smart
+ | list |
- | list rec ans oldStruct newStruct |
"Go through the renamed classes. Ask the user if it could be in a project. Add a method in SmartRefStream, and a conversion method in the new class."
list := OrderedCollection new.
+ renamed do: [:cls | | rec ans oldStruct newStruct |
- renamed do: [:cls |
rec := changeRecords at: cls name.
rec priorName ifNotNil: [
ans := UIManager default chooseFrom:
#('Yes, write code to convert those instances'
'No, no instances are in projects')
title: 'You renamed class ', rec priorName,
' to be ', rec thisName,
'.\Could an instance of ', rec priorName,
' be in a project on someone''s disk?'.
ans = 1 ifTrue: [
oldStruct := structures at: rec priorName ifAbsent: [nil].
newStruct := (Array with: cls classVersion), (cls allInstVarNames).
oldStruct ifNotNil: [
smart writeConversionMethodIn: cls fromInstVars: oldStruct
to: newStruct renamedFrom: rec priorName.
smart writeClassRename: cls name was: rec priorName.
list add: cls name, ' convertToCurrentVersion:refStream:']]
ifFalse: [structures removeKey: rec priorName ifAbsent: []]]].
list isEmpty ifTrue: [^ msgSet].
msgSet messageList ifNil: [msgSet initializeMessageList: list]
ifNotNil: [list do: [:item | msgSet addItem: item]].
^ msgSet!
Item was changed:
----- Method: ChangeSet>>checkForConversionMethods (in category 'fileIn/Out') -----
checkForConversionMethods
"See if any conversion methods are needed"
+ | tell choice smart restore renamed listAdd listDrop msgSet list |
- | oldStruct newStruct tell choice list need
- sel smart restore renamed listAdd listDrop msgSet rec nn |
Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference"
structures ifNil: [^ self].
list := OrderedCollection new.
renamed := OrderedCollection new.
+ self changedClasses do: [:class | | newStruct sel oldStruct need rec |
- self changedClasses do: [:class |
need := (self atClass: class includes: #new) not.
need ifTrue: ["Renamed classes."
(self atClass: class includes: #rename) ifTrue: [
rec := changeRecords at: class name.
rec priorName ifNotNil: [
(structures includesKey: rec priorName) ifTrue: [
renamed add: class. need := false]]]].
need ifTrue: [need := (self atClass: class includes: #change)].
need ifTrue: [oldStruct := structures at: class name
ifAbsent: [need := false. #()]].
need ifTrue: [
newStruct := (Array with: class classVersion), (class allInstVarNames).
need := (oldStruct ~= newStruct)].
need ifTrue: [sel := #convertToCurrentVersion:refStream:.
(#(add change) includes: (self atSelector: sel class: class)) ifFalse: [
list add: class]].
].
list isEmpty & renamed isEmpty ifTrue: [^ self].
"Ask user if want to do this"
tell := 'If there might be instances of ', (list asArray, renamed asArray) printString,
'\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\'
withCRs,
'After you edit the conversion method, you''ll need to fileOut again.\' withCRs,
'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'.
choice := UIManager default chooseFrom:
'Write a conversion method by editing a prototype
These classes are not used in any object file. fileOut my changes now.
I''m too busy. fileOut my changes now.
Don''t ever ask again. fileOut my changes now.' withCRs title: tell.
choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
choice = 2 ifTrue: ["Don't consider this class again in the changeSet"
list do: [:cls | structures removeKey: cls name ifAbsent: []].
+ renamed do: [:cls | | nn |
- renamed do: [:cls |
nn := (changeRecords at: cls name) priorName.
structures removeKey: nn ifAbsent: []]].
choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4"
listAdd := self askAddedInstVars: list. "Go through each inst var that was added"
listDrop := self askRemovedInstVars: list. "Go through each inst var that was removed"
list := (listAdd, listDrop) asSet asArray.
smart := SmartRefStream on: (RWBinaryOrTextStream on: '12345').
smart structures: structures.
smart superclasses: superclasses.
(restore := self class current) == self ifFalse: [
self class newChanges: self]. "if not current one"
msgSet := smart conversionMethodsFor: list.
"each new method is added to self (a changeSet). Then filed out with the rest."
self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods"
restore == self ifFalse: [self class newChanges: restore].
msgSet isEmpty ifTrue: [^ self].
self inform: 'Remember to fileOut again after modifying these methods.'.
ToolSet browseMessageSet: msgSet name: 'Conversion methods for ', self name autoSelect: false.!
Item was changed:
----- Method: Utilities class>>writeList:toStream: (in category 'fetching updates') -----
writeList: listContents toStream: strm
"Write a parsed updates.list out as text.
This is the inverse of parseListContents:"
+
- | fileNames version |
strm reset.
listContents do:
+ [:pair | | version fileNames |
+ version := pair first. fileNames := pair last.
- [:pair | version := pair first. fileNames := pair last.
strm nextPut: $#; nextPutAll: version; cr.
fileNames do: [:fileName | strm nextPutAll: fileName; cr]].
strm close!
Item was changed:
----- Method: ChangeRecord>>timeStamp (in category 'access') -----
timeStamp
"Answer a TimeStamp that corresponds to my (text) stamp"
+ | tokens |
- | tokens date time |
tokens := self stamp findTokens: Character separators.
^ tokens size > 2
+ ifTrue: [[| date time |
+ date := Date fromString: (tokens at: tokens size - 1).
- ifTrue: [[date := Date
- fromString: (tokens at: tokens size - 1).
time := Time fromString: tokens last.
TimeStamp date: date time: time]
on: Error
do: [:ex | ex
return: (TimeStamp fromSeconds: 0)]]
ifFalse: [TimeStamp fromSeconds: 0]!
Item was changed:
----- Method: Utilities class>>objectStrmFromUpdates: (in category 'fetching updates') -----
objectStrmFromUpdates: fileName
"Go to the known servers and look for this file in the updates folder. It is an auxillery file, like .morph or a .gif. Return a RWBinaryOrTextStream on it. Meant to be called from during the getting of updates from the server. That assures that (Utilities serverUrls) returns the right group of servers."
+
- | urls doc |
Cursor wait showWhile:
+ [ | urls |urls := Utilities serverUrls collect: [:url | url, 'updates/', fileName].
+ urls do: [:aUrl | | doc |
- [urls := Utilities serverUrls collect: [:url | url, 'updates/', fileName].
- urls do: [:aUrl |
doc := HTTPSocket httpGet: aUrl accept: 'application/octet-stream'.
"test here for server being up"
doc class == RWBinaryOrTextStream ifTrue: [^ doc reset]]].
self inform: 'All update servers are unavailable, or bad file name'.
^ nil!
Item was changed:
----- Method: TextDiffBuilder>>incorporateMatchesInto: (in category 'creating patches') -----
incorporateMatchesInto: aPatchSequence
"Incorporate matches"
+
+ runs associationsDo:[:assoc| | index |
- | index |
- runs associationsDo:[:assoc|
index := assoc key y.
assoc value do:[:line|
self assert:[(aPatchSequence at: index) isNil].
aPatchSequence at: index put: (#match -> line).
index := index + 1.
].
].
!
Item was changed:
----- Method: CodeLoader>>loadSegments: (in category 'loading') -----
loadSegments: anArray
"Load all the source files in the given array."
+ | loader |
- | loader request |
loader := HTTPLoader default.
segments := anArray collect:[:name |
+ | reqName request |
- | reqName |
reqName := (FileDirectory extensionFor: name) isEmpty
ifTrue: [FileDirectory fileName: name extension: ImageSegment compressedFileExtension]
ifFalse: [name].
request := self createRequestFor: reqName in: loader.
name->request].
!
Item was changed:
----- Method: Preferences class>>installMissingWindowColors (in category 'window colors') -----
installMissingWindowColors
"Install the factory-provided bright window colors -- a one-time bootstrap"
"Preferences installMissingWindowColors"
+
- | color |
self windowColorTable do:
+ [:aColorSpec | | color |
- [:aColorSpec |
color := (Color colorFrom: aColorSpec brightColor).
self setWindowColorFor: aColorSpec classSymbol to: color]!
Item was changed:
----- Method: ChangeSet class>>newChangesFromStream:named: (in category 'services') -----
newChangesFromStream: aStream named: aName
"File in the code from the stream into a new change set whose
name is derived from aName. Leave the 'current change set'
unchanged. Return the new change set or nil on failure."
+ | oldChanges newName newSet |
- | oldChanges newName newSet newStream |
oldChanges := ChangeSet current.
PreviousSet := oldChanges name. "so a Bumper update can find it"
newName := aName sansPeriodSuffix.
newSet := self basicNewChangeSet: newName.
+ [ | newStream |newSet ifNotNil:[
- [newSet ifNotNil:[
(aStream respondsTo: #converter:) ifFalse: [
newStream := MultiByteBinaryOrTextStream with: (aStream contentsOfEntireFile).
newStream reset.
] ifTrue: [
newStream := aStream.
].
self newChanges: newSet.
newStream setConverterForCode.
newStream fileInAnnouncing: 'Loading ', newName, '...'.
Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName].
aStream close] ensure: [self newChanges: oldChanges].
PreviousSet := nil.
^ newSet!
Item was changed:
----- Method: Utilities class>>purgeRecentSubmissionsOfMissingMethods (in category 'recent method submissions') -----
purgeRecentSubmissionsOfMissingMethods
"Utilities purgeRecentSubmissionsOfMissingMethods"
+
- | keep |
self flag: #mref. "fix for faster references to methods"
RecentSubmissions := RecentSubmissions select:
+ [:aSubmission | | keep |
- [:aSubmission |
Utilities setClassAndSelectorFrom: aSubmission in:
[:aClass :aSelector |
keep := (aClass == nil) not
and: [aClass isInMemory
and: [aSelector == #Comment or: [(aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil]]]].
keep]!
Item was changed:
----- Method: SmalltalkImage>>saveAsEmbeddedImage (in category 'sources, changes log') -----
saveAsEmbeddedImage
"Save the current state of the system as an embedded image"
+ | dir newName newImageName oldImageSegDir haveSegs |
- | dir newName newImageName newImageSegDir oldImageSegDir haveSegs |
dir := FileDirectory default.
newName := UIManager default request: 'Select existing VM file'
initialAnswer: (FileDirectory localNameFor: '').
newName = '' ifTrue: [^Smalltalk].
newName := FileDirectory baseNameFor: newName asFileName.
newImageName := newName.
(dir includesKey: newImageName)
ifFalse:
[^self
inform: 'Unable to find name ' , newName , ' Please choose another name.'].
haveSegs := false.
Smalltalk at: #ImageSegment
ifPresent:
[:theClass |
(haveSegs := theClass instanceCount ~= 0)
ifTrue: [oldImageSegDir := theClass segmentDirectory]].
self logChange: '----SAVEAS (EMBEDDED) ' , newName , '----'
, Date dateAndTimeNow printString.
self imageName: (dir fullNameFor: newImageName) asSqueakPathName.
LastImageName := self imageName.
self closeSourceFiles.
haveSegs
ifTrue:
[Smalltalk at: #ImageSegment
ifPresent:
+ [:theClass | | newImageSegDir |
- [:theClass |
newImageSegDir := theClass segmentDirectory. "create the folder"
oldImageSegDir fileNames do:
[:theName |
"copy all segment files"
newImageSegDir
copyFileNamed: oldImageSegDir pathName , FileDirectory slash , theName
toFileNamed: theName]]].
self
snapshot: true
andQuit: true
embedded: true!
Item was changed:
----- Method: ReferenceStream>>statisticsOfRefs (in category 'statistics') -----
statisticsOfRefs
"Analyze the information in references, the objects being written out"
+ | parents ownerBags tallies n nm owners |
- | parents n kids nm ownerBags tallies owners objParent |
parents := IdentityDictionary new: references size * 2.
n := 0.
'Finding Owners...'
displayProgressAt: Sensor cursorPoint
from: 0 to: references size
during: [:bar |
references keysDo:
+ [:parent | | kids |
+ bar value: (n := n+1).
- [:parent | bar value: (n := n+1).
kids := parent class isFixed
ifTrue: [(1 to: parent class instSize) collect: [:i | parent
instVarAt: i]]
ifFalse: [parent class isBits ifTrue: [Array new]
ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt:
i]]].
(kids select: [:x | references includesKey: x])
do: [:child | parents at: child put: parent]]].
ownerBags := Dictionary new.
tallies := Bag new.
n := 0.
'Tallying Owners...'
displayProgressAt: Sensor cursorPoint
from: 0 to: references size
during: [:bar |
references keysDo: "For each class of obj, tally a bag of owner
classes"
+ [:obj | | objParent | bar value: (n := n+1).
- [:obj | bar value: (n := n+1).
nm := obj class name.
tallies add: nm.
owners := ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new].
(objParent := parents at: obj ifAbsent: [nil]) == nil
ifFalse: [owners add: objParent class name]]].
^ String streamContents:
[:strm | tallies sortedCounts do:
[:assn | n := assn key. nm := assn value.
owners := ownerBags at: nm.
strm cr; nextPutAll: nm; space; print: n.
owners size > 0 ifTrue:
[strm cr; tab; print: owners sortedCounts]]]!
Item was changed:
----- Method: SystemDictionary>>renameClass:as: (in category 'class and trait names') -----
renameClass: aClass as: newName
"Rename the class, aClass, to have the title newName."
"Original one I want to keep but needs to be fixed"
+ | oldref oldName category |
- | oldref i oldName category |
oldName := aClass name.
category := aClass category.
SystemOrganization classify: newName under: aClass category.
SystemOrganization removeElement: aClass name.
oldref := self associationAt: aClass name.
self removeKey: aClass name.
oldref key: newName.
self add: oldref. "Old association preserves old refs"
(Array with: StartUpList with: ShutDownList) do:
+ [:list | | i | i := list indexOf: aClass name ifAbsent: [0].
- [:list | i := list indexOf: aClass name ifAbsent: [0].
i > 0 ifTrue: [list at: i put: newName]].
self flushClassNameCache.
SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category!
Item was changed:
----- Method: ImageSegment class>>discoverActiveClasses (in category 'testing') -----
discoverActiveClasses "ImageSegment discoverActiveClasses"
"Run this method, do a few things, maybe save and resume the image.
This will leave unused classes with MDFaults.
You MUST follow this soon by activeClasses, or by swapOutInactiveClasses."
"NOTE: discoverActiveClasses uses Squeak's ability to detect and recover from faults due to a nil method dictionary. It staches the method dict in with the organization during the time when discovery is in progress (Gag me with a spoon). This is why the faults need to be cleared promptly before resuming normal work with the system. It is also important that classes *do not* refer directly to their method dictionary, but only via the accessor message."
+
- | ok |
Smalltalk allClasses do:
+ [:c | | ok | ok := true.
- [:c | ok := true.
#(Array Object Class Message MethodDictionary) do:
[:n | ((Smalltalk at: n) == c or:
[(Smalltalk at: n) inheritsFrom: c]) ifTrue: [ok := false]].
ok ifTrue: [c induceMDFault]].
"
ImageSegment discoverActiveClasses.
-- do something typical --
PopUpMenu notify: ImageSegment activeClasses size printString , ' classes were active out of ' ,
Smalltalk allClasses size printString.
"!
Item was changed:
----- Method: ChangeSet>>fileOut (in category 'fileIn/Out') -----
fileOut
"File out the receiver, to a file whose name is a function of the
change-set name and either of the date & time or chosen to have a
unique numeric tag, depending on the preference
'changeSetVersionNumbers'"
+ | slips nameToUse |
- | slips nameToUse internalStream |
self checkForConversionMethods.
ChangeSet promptForDefaultChangeSetDirectoryIfNecessary.
nameToUse := Preferences changeSetVersionNumbers
ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: FileStream cs]
ifFalse: [self name , FileDirectory dot , Utilities dateTimeSuffix, FileDirectory dot , FileStream cs].
nameToUse := self defaultChangeSetDirectory fullNameFor: nameToUse.
+ Cursor write showWhile: [ | internalStream |
- Cursor write showWhile: [
internalStream := WriteStream on: (String new: 10000).
internalStream header; timeStamp.
self fileOutPreambleOn: internalStream.
self fileOutOn: internalStream.
self fileOutPostscriptOn: internalStream.
internalStream trailer.
FileStream writeSourceCodeFrom: internalStream baseName: (nameToUse copyFrom: 1 to: nameToUse size - 3) isSt: false useHtml: false.
].
Preferences checkForSlips
ifFalse: [^ self].
slips := self checkForSlips.
(slips size > 0
and: [(UIManager default chooseFrom: #('Ignore' 'Browse slips')
title: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?')
= 2])
ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]!
Item was changed:
----- Method: ChangeSet>>methodChanges (in category 'accessing') -----
methodChanges
+ | methodChangeDict |
- | methodChangeDict changeTypes |
methodChangeDict := Dictionary new.
changeRecords associationsDo:
+ [:assn | | changeTypes |
- [:assn |
changeTypes := assn value methodChangeTypes.
changeTypes isEmpty ifFalse: [methodChangeDict at: assn key put: changeTypes]].
^ methodChangeDict!
Item was changed:
----- Method: SystemDictionary>>send:toClassesNamedIn:with: (in category 'snapshot and quit') -----
send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument
"Send the message #startUp: or #shutDown: to each class named in the list.
The argument indicates if the system is about to quit (for #shutDown:) or if
the image is resuming (for #startUp:).
If any name cannot be found, then remove it from the list."
+ | removals |
- | removals class |
removals := OrderedCollection new.
startUpOrShutDownList do:
+ [:name | | class |
- [:name |
class := self at: name ifAbsent: [nil].
class == nil
ifTrue: [removals add: name]
ifFalse: [class isInMemory ifTrue:
[class perform: startUpOrShutDown with: argument]]].
"Remove any obsolete entries, but after the iteration"
startUpOrShutDownList removeAll: removals!
Item was changed:
----- Method: SARInstaller class>>ensurePackageWithId: (in category 'package format support') -----
ensurePackageWithId: anIdString
+ self squeakMapDo: [ :sm | | newCS |
- self squeakMapDo: [ :sm | | card newCS |
self withCurrentChangeSetNamed: 'updates' do: [ :cs |
+ | card |
newCS := cs.
card := sm cardWithId: anIdString.
(card isNil or: [ card isInstalled not or: [ card isOld ]])
ifTrue: [ sm installPackageWithId: anIdString ]
].
newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ]
].!
Item was changed:
----- Method: ChangeSet>>checkForSlips (in category 'fileIn/Out') -----
checkForSlips
"Return a collection of method refs with possible debugging code in them."
+ | slips |
- | slips method |
slips := OrderedCollection new.
self changedClasses do:
[:aClass |
(self methodChangesAtClass: aClass name) associationsDo:
+ [:mAssoc | | method | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
- [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
[method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
method ifNotNil:
[method hasReportableSlip
ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
^ slips!
Item was changed:
----- Method: SystemDictionary>>removeAllLineFeeds (in category 'housekeeping') -----
removeAllLineFeeds
"Smalltalk removeAllLineFeeds"
"Scan all methods for source code with lineFeeds.
Replaces all occurrences of <CR><LF> or <LF> by <CR>.
When done, offers to display an Inspector containing the message
names grouped by author initials.
In this dictionary, the key 'OK' contains the methods that had literals that contained <LF> characters."
+ | totalStripped totalOK authors |
- | n authors totalStripped totalOK |
'Scanning sources for LineFeeds.
This will take a few minutes...'
displayProgressAt: Sensor cursorPoint
from: 0
to: CompiledMethod instanceCount
+ during: [:bar | | n |
- during: [:bar |
n := 0.
authors := self
removeAllLineFeedsQuietlyCalling: [:cls :sel | (n := n + 1) \\ 100 = 0
ifTrue: [bar value: n]]].
totalStripped := authors
inject: 1
into: [:sum :set | sum + set size].
totalOK := (authors at: 'OK') size.
totalStripped := totalStripped - totalOK.
Transcript cr; show: totalStripped printString , ' methods stripped of LFs.'.
Transcript cr; show: totalOK printString , ' methods still correctly contain LFs.'.
(self confirm: 'Do you want to see the affected methods?')
ifTrue: [authors inspect]!
Item was changed:
----- Method: Preferences class>>setNotificationParametersForStandardPreferences (in category 'reacting to change') -----
setNotificationParametersForStandardPreferences
"Set up the notification parameters for the standard preferences that require need them. When adding new Preferences that require use of the notification mechanism, users declare the notifcation info as part of the call that adds the preference, or afterwards -- the two relevant methods for doing that are:
Preferences.addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector: and
Preference changeInformee:changeSelector:"
"Preferences setNotificationParametersForStandardPreferences"
+
- | aPreference |
#(
(annotationPanes annotationPanesChanged)
(eToyFriendly eToyFriendlyChanged)
(infiniteUndo infiniteUndoChanged)
(uniTilesClassic classicTilesSettingToggled)
(optionalButtons optionalButtonsChanged)
(roundedWindowCorners roundedWindowCornersChanged)
(showProjectNavigator showProjectNavigatorChanged)
(smartUpdating smartUpdatingChanged)
(universalTiles universalTilesSettingToggled)
(showSharedFlaps sharedFlapsSettingChanged)
(noviceMode noviceModeSettingChanged)
) do:
+ [:pair | | aPreference |
- [:pair |
aPreference := self preferenceAt: pair first.
aPreference changeInformee: self changeSelector: pair second]!
Item was changed:
----- Method: SmartRefStream>>checkCrLf (in category 'read write') -----
checkCrLf
+ | save isCrLf cc loneLf |
- | save isCrLf cc prev loneLf |
"Watch for a file that has had all of its Cr's converted to CrLf's. Some unpacking programs like Stuffit 5.0 do this by default!!"
save := byteStream position.
isCrLf := false. loneLf := false.
cc := 0.
+ 350 timesRepeat: [ | prev |
- 350 timesRepeat: [
prev := cc.
(cc := byteStream next) = 16r0A "Lf" ifTrue: [
prev = 16r0D "Cr" ifTrue: [isCrLf := true] ifFalse: [loneLf := true]].
].
isCrLf & (loneLf not) ifTrue: [
self inform: 'Carriage Returns in this file were converted to CrLfs
by an evil unpacking utility. Please set the preferences in
StuffIt Expander to "do not convert file formats"'].
byteStream position: save.
!
Item was changed:
----- Method: Preferences class>>annotationEditingWindow (in category 'parameters') -----
annotationEditingWindow
"Answer a window affording editing of annotations"
+ | aPanel ins outs current aWindow aButton info standardHeight standardWidth aMorph |
- | aPanel ins outs current aMorph aWindow aButton info pair standardHeight standardWidth |
standardHeight := 180.
standardWidth := (2 sqrt reciprocal * standardHeight) rounded.
Smalltalk isMorphic
ifFalse: [self error: 'annotations can be edited only in morphic'].
aPanel := AlignmentMorph newRow extent: 2 * standardWidth @ standardHeight.
ins := AlignmentMorph newColumn extent: standardWidth @ standardHeight.
ins color: Color green muchLighter.
ins enableDrop: true;
beSticky.
outs := AlignmentMorph newColumn extent: standardWidth @ standardHeight.
outs color: Color red muchLighter.
outs enableDrop: true;
beSticky.
aPanel addMorph: outs;
addMorphFront: ins.
outs position: ins position + (standardWidth @ 0).
current := self defaultAnnotationRequests.
info := self annotationInfo.
current
+ do: [:sym | | pair |
- do: [:sym |
pair := info
detect: [:aPair | aPair first == sym].
aMorph := StringMorph new contents: pair first.
aMorph setBalloonText: pair last.
aMorph enableDrag: true.
aMorph
on: #startDrag
send: #startDrag:with:
to: aMorph.
ins addMorphBack: aMorph].
info
do: [:aPair | (current includes: aPair first)
ifFalse: [aMorph := StringMorph new contents: aPair first.
aMorph setBalloonText: aPair last.
aMorph enableDrag: true.
aMorph
on: #startDrag
send: #startDrag:with:
to: aMorph.
outs addMorph: aMorph]].
aPanel layoutChanged.
aWindow := SystemWindowWithButton new setLabel: 'Annotations'.
aButton := SimpleButtonMorph new target: Preferences;
actionSelector: #acceptAnnotationsFrom:;
arguments: (Array with: aWindow);
label: 'apply';
borderWidth: 0;
borderColor: Color transparent;
color: Color transparent.
aButton submorphs first color: Color blue.
aButton setBalloonText: 'After moving all the annotations you want to the left (green) side, and all the ones you do NOT want to the right (pink) side, hit this "apply" button to have your choices take effect.'.
aWindow buttonInTitle: aButton;
adjustExtraButton.
^ aPanel wrappedInWindow: aWindow"Preferences annotationEditingWindow openInHand"!
Item was changed:
----- Method: ChangeSet>>askRemovedInstVars: (in category 'fileIn/Out') -----
askRemovedInstVars: classList
+ | pairList pairClasses index pls |
- | pairList pairClasses index pls newStruct oldStruct |
"Ask the author whether these newly removed inst vars need to have their info saved"
pairList := OrderedCollection new.
pairClasses := OrderedCollection new.
"Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here."
+ classList do: [:cls | | oldStruct newStruct |
- classList do: [:cls |
newStruct := (cls allInstVarNames).
oldStruct := (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst.
oldStruct do: [:instVarName |
(newStruct includes: instVarName) ifFalse: [
pairList add: cls name, ' ', instVarName.
pairClasses add: cls]]].
pairList isEmpty ifTrue: [^ #()].
[index := UIManager default
chooseFrom: pairList, #('all of these need a conversion method'
'all of these have old values that can be erased')
title:
'These instance variables were removed.
When an old project comes in, instance variables
that have been removed will lose their contents.
Click on items to remove them from the list.
Click on any whose value is unimportant and need not be saved.'.
(index <= (pls := pairList size)) & (index > 0) ifTrue: [
pairList removeAt: index.
pairClasses removeAt: index].
index = (pls + 2) ifTrue: ["all are OK" ^ #()].
pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse.
^ pairClasses asSet asArray "non redundant"!
Item was changed:
----- Method: ImageSegment>>rootsIncludingBlockMethods (in category 'read/write segment') -----
rootsIncludingBlockMethods
"Return a new roots array with more objects. (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment. Put such methods into the roots list. Then ask for the segment again."
+ | myClasses extras |
- | extras myClasses gotIt |
userRootCnt ifNil: [userRootCnt := arrayOfRoots size].
extras := OrderedCollection new.
myClasses := OrderedCollection new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [
myClasses add: aRoot]].
myClasses isEmpty ifTrue: [^ nil]. "no change"
+ outPointers do: [:anOut | | gotIt |
- outPointers do: [:anOut |
anOut class == CompiledMethod ifTrue: [
"specialized version of who"
gotIt := false.
myClasses detect: [:class |
class selectorsDo: [:sel |
(class compiledMethodAt: sel) == anOut
ifTrue: [extras add: anOut. gotIt := true]].
gotIt]
ifNone: []
].
anOut := nil].
extras := extras select: [:ea | (arrayOfRoots includes: ea) not].
extras isEmpty ifTrue: [^ nil]. "no change"
^ arrayOfRoots, extras!
Item was changed:
----- Method: Preferences class>>giveHelpWithPreferences (in category 'misc') -----
giveHelpWithPreferences
"Open up a workspace with explanatory info in it about Preferences"
+ | aString |
- | aString aHelpString |
aString := String streamContents: [:aStream |
aStream nextPutAll:
'Many aspects of the system are governed by the settings of various "Preferences".
Click on any of brown tabs at the top of the panel to see all the preferences in that category.
Or type in to the box above the Search button, then hit Search, and all Preferences matching whatever you typed in will appear in the "search results" category. A preference is considered to match your search if either its name matches the characters *or* if anything in the balloon help provided for the preferences matches the search text.
To find out more about any particular Preference, hold the mouse over it for a moment and balloon help will appear. Also, a complete list of all the Preferences, with documentation for each, is included below.
Preferences whose names are in shown in bold in the Preferences Panel are designated as being allowed to vary from project to project; those whose name are not in bold are "global", which is to say, they apply equally whatever project you are in.
Click on the name of any preference to get a menu which allows you to *change* whether the preference should vary from project to project or should be global, and also allows you to browse all the senders of the preference, and to discover all the categories under which the preference has been classified, and to be handed a button that you can drop wherever you please that will control the preference.
If you like all your current Preferences settings, you may wish to hit the "Save Current Settings as my Personal Preferences" button. Once you have done that, you can at any point in the future hit "Restore my Personal Preferences" and all your saved settings will get restored immediately.
Also, you can use "themes" to set multiple preferences all at once; click on the "change theme..." button in the Squeak flap or in the Preferences panel, or seek out the themes item in the Appearance menu.' translated.
aStream cr; cr; nextPutAll: '-----------------------------------------------------------------';
cr; cr; nextPutAll: 'Alphabetical listing of all Preferences' translated; cr; cr.
(Preferences allPreferenceObjects asSortedCollection: [:a :b | a name < b name]) do:
+ [:pref | | aHelpString |
- [:pref |
aStream nextPutAll: pref name; cr.
aHelpString := pref helpString translated.
(aHelpString beginsWith: pref name) ifTrue:
[aHelpString := aHelpString copyFrom: (pref name size + 3) to: aHelpString size].
aHelpString := (aHelpString copyReplaceAll: String cr with: ' ') copyWithout: Character tab.
aStream nextPutAll: aHelpString capitalized.
(aHelpString isEmpty or: [aHelpString last == $.]) ifFalse: [aStream nextPut: $.].
aStream cr; cr]].
UIManager default edit: aString label: 'About Preferences' translated
"Preferences giveHelpWithPreferences"!
Item was changed:
----- Method: Utilities class>>decommissionTheAllCategory (in category 'miscellaneous') -----
decommissionTheAllCategory
"Utilities decommissionTheAllCategory"
"Moves all methods that are in a category named 'all' into the default 'as yet unclassified' category"
+ | methodCount classCount |
- | org aCategory methodCount classCount any |
self flag: #ShouldBeMovedIntoClassOrganization. "sd"
methodCount := 0.
classCount := 0.
self systemNavigation allBehaviorsDo:
+ [:aClass | | org any | org := aClass organization.
- [:aClass | org := aClass organization.
any := false.
aClass selectorsDo:
+ [:aSelector | | aCategory |
- [:aSelector |
aCategory := org categoryOfElement: aSelector.
aCategory = #all ifTrue:
[org classify: aSelector under: ClassOrganizer default suppressIfDefault: false.
methodCount := methodCount + 1.
any := true]].
any ifTrue: [classCount := classCount + 1].
org removeEmptyCategories].
Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved
from "all" to "as yet unclassified"'
!
Item was changed:
----- Method: SmartRefStream>>recordImageSegment: (in category 'read write') -----
recordImageSegment: refs
"Besides the objects being written out, record the structure of instances inside the image segment we are writing out."
+ | list |
- | cls list |
"Do not record Player class inst vars. They are in the segement."
+ refs keysDo: [:each | | cls |
- refs keysDo: [:each |
cls := each class.
cls isObsolete ifTrue: [self error: 'Trying to write ', cls name].
cls class == Metaclass
ifFalse: [structures at: cls name put: false.
(each isKindOf: ImageSegment) ifTrue: [
each outPointers do: [:out |
(out isKindOf: Class) ifTrue: [
structures at: out theNonMetaClass name put: false].
out class == DiskProxy ifTrue: [
out simpleGlobalOrNil ifNotNil: [
(out simpleGlobalOrNil isKindOf: Class) ifTrue: [
structures at: out simpleGlobalOrNil name put: false]]]].
"each arrayOfRoots do: [:rr | (rr isKindOf: Class) ifTrue: [
structures at: rr theNonMetaClass name put: false]]."
"all classes in roots are local to seg"]]].
list := refs at: #BlockReceiverClasses ifAbsent: [^ self].
list do: [:meta | structures at: meta name put: false].
"Just the metaclasses whose instances are block receivers. Otherwise metaclasses are not allowed."!
Item was changed:
----- Method: SystemNavigation>>obsoleteMethodReferences (in category 'query') -----
obsoleteMethodReferences
"SystemNavigation default obsoleteMethodReferences"
"Open a browser on all referenced behaviors that are obsolete"
+ | obsClasses references |
- | obsClasses obsRefs references |
references := WriteStream on: Array new.
obsClasses := self obsoleteBehaviors.
'Scanning for methods referencing obsolete classes'
displayProgressAt: Sensor cursorPoint
from: 1
to: obsClasses size
during:
[:bar |
obsClasses keysAndValuesDo:
+ [:index :each | | obsRefs |
- [:index :each |
bar value: index.
obsRefs := Utilities pointersTo: each except: obsClasses.
obsRefs do:
[:ref |
"Figure out if it may be a global"
(ref isVariableBinding and: [ref key isString "or Symbol"])
ifTrue:
[(Utilities pointersTo: ref) do:
[:meth |
(meth isKindOf: CompiledMethod)
ifTrue: [meth methodReference ifNotNil: [:mref | references nextPut: mref]]]]]]].
^references contents!
Item was changed:
----- Method: Preferences class>>prefEvent: (in category 'dynamic preferences') -----
prefEvent: anEvent
"Check if this system event defines or removes a preference.
TODO: Queue the event and handle in background process.
There is zero reason to be so eager here."
+ | aClass aSelector prefSymbol method |
- | aClass aSelector prefSymbol method aPrefSymbol aPreference |
(anEvent itemKind = SystemChangeNotifier classKind and: [anEvent isRemoved])
ifTrue:[self removePreferencesFor: anEvent item].
anEvent itemKind = SystemChangeNotifier methodKind ifTrue:[
aClass := anEvent itemClass.
aClass isMeta ifFalse:[^self]. "ignore instance methods"
aClass := aClass theNonMetaClass.
aSelector := anEvent itemSelector.
(anEvent isRemoved or:[anEvent isModified]) ifTrue:[
prefSymbol := (aClass name,'>>', aSelector) asSymbol.
self dictionaryOfPreferences removeKey: prefSymbol ifAbsent:[]].
(anEvent isAdded or:[anEvent isModified]) ifTrue:[
method := anEvent item.
+ method pragmas do:[:pragma| | aPreference aPrefSymbol |
- method pragmas do:[:pragma|
pragma keyword == #preference:category:description:type: ifTrue:[
aPrefSymbol := (aClass name,'>>', method selector) asSymbol.
aPreference := self
preference: pragma arguments first
category: pragma arguments second
description: pragma arguments third
type: pragma arguments fourth.
aPreference
provider: aClass
getter: method selector
setter: method selector asMutator.
self dictionaryOfPreferences at: aPrefSymbol put: aPreference]]]].
!
Item was changed:
----- Method: SystemDictionary>>removeAllLineFeedsQuietlyCalling: (in category 'housekeeping') -----
removeAllLineFeedsQuietlyCalling: aBlock
"Smalltalk removeAllLineFeedsQuietly"
"Scan all methods for source code with lineFeeds.
Replaces all occurrences of <CR><LF> or <LF> by <CR>.
Answer a Dictionary keyed by author name containing sets of affected method names,
as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters.
Evaluate aBlock for each method so that status can be updated."
+ | authors |
- | oldCodeString newCodeString oldStamp oldCategory authors nameString |
self forgetDoIts.
authors := Dictionary new.
authors at: 'OK' put: Set new.
self systemNavigation
allBehaviorsDo: [:cls | cls selectors
+ do: [:selector | | oldCodeString oldStamp oldCategory newCodeString nameString |
- do: [:selector |
aBlock value: cls value: selector.
oldCodeString := cls sourceCodeAt: selector.
(oldCodeString includes: Character lf)
ifTrue: [
newCodeString := oldCodeString withSqueakLineEndings.
nameString := cls name , '>>' , selector.
((cls compiledMethodAt: selector) hasLiteralSuchThat: [ :lit | lit asString includes: Character lf ])
ifTrue: [(authors at: 'OK')
add: nameString]
ifFalse: [oldStamp := (Utilities
timeStampForMethod: (cls compiledMethodAt: selector))
copy replaceAll: Character cr
with: Character space.
(authors
at: (oldStamp copyFrom: 1 to: (oldStamp findFirst: [ :c | c isAlphaNumeric not ]))
ifAbsentPut: [Set new])
add: nameString.
oldCategory := cls whichCategoryIncludesSelector: selector.
cls
compile: newCodeString
classified: oldCategory
withStamp: oldStamp
notifying: nil ]]]].
^ authors!
Item was changed:
----- Method: NaturalLanguageTranslator class>>mergeTranslationFileNamed: (in category 'file-services') -----
mergeTranslationFileNamed: fileFullNameString
"merge the translation in the file named fileFullNameString"
+ | stream |
- | stream localeID translator |
stream := FileStream readOnlyFileNamed: fileFullNameString.
+ [ | localeID translator |
+ localeID := LocaleID isoString: stream localName sansPeriodSuffix.
- [localeID := LocaleID isoString: stream localName sansPeriodSuffix.
translator := self localeID: localeID.
translator loadFromStream: stream]
ensure: [stream close].
LanguageEnvironment resetKnownEnvironments.
!
Item was changed:
----- Method: ClassChangeRecord>>assimilateAllChangesIn: (in category 'all changes') -----
assimilateAllChangesIn: otherRecord
- | selector changeRecord changeType |
otherRecord isClassRemoval ifTrue: [^ self noteChangeType: #remove].
otherRecord allChangeTypes do:
[:chg | self noteChangeType: chg fromClass: self realClass].
otherRecord methodChanges associationsDo:
+ [:assn | | selector changeRecord changeType |
+ selector := assn key. changeRecord := assn value.
- [:assn | selector := assn key. changeRecord := assn value.
changeType := changeRecord changeType.
(changeType == #remove or: [changeType == #addedThenRemoved])
ifTrue:
[changeType == #addedThenRemoved
ifTrue: [self atSelector: selector put: #add].
self noteRemoveSelector: selector priorMethod: nil
lastMethodInfo: changeRecord methodInfoFromRemoval]
ifFalse:
[self atSelector: selector put: changeType]].
!
Item was changed:
----- Method: SmalltalkImage>>reconstructChanges2 (in category 'housekeeping') -----
reconstructChanges2
"Move all the changes and its histories onto another sources file."
"SmalltalkImage reconstructChanges2"
+ | f oldChanges |
- | f oldChanges classCount |
f := FileStream fileNamed: 'ST80.temp'.
f header; timeStamp.
(SourceFiles at: 2) converter: MacRomanTextConverter new.
'Recoding Changes File...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
during:
+ [:bar | | classCount | classCount := 0.
- [:bar | classCount := 0.
Smalltalk allClassesDo:
[:class | bar value: (classCount := classCount + 1).
class moveChangesWithVersionsTo: f.
class putClassCommentToCondensedChangesFile: f.
class class moveChangesWithVersionsTo: f]].
self lastQuitLogPosition: f position.
f trailer; close.
oldChanges := SourceFiles at: 2.
oldChanges close.
FileDirectory default
deleteFileNamed: oldChanges name , '.old';
rename: oldChanges name toBe: oldChanges name , '.old';
rename: f name toBe: oldChanges name.
Smalltalk setMacFileInfoOn: oldChanges name.
SourceFiles at: 2
put: (FileStream oldFileNamed: oldChanges name)!
Item was changed:
----- Method: ChangeRecord>>fileIn (in category 'initialization') -----
fileIn
"File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it."
- | methodClass s aSelector |
Cursor read showWhile:
+ [| methodClass s aSelector |
+ (methodClass := self methodClass) notNil ifTrue:
- [(methodClass := self methodClass) notNil ifTrue:
[methodClass compile: self text classified: category withStamp: stamp notifying: nil.
(aSelector := self methodSelector) ifNotNil:
[Utilities noteMethodSubmission: aSelector forClass: methodClass]].
(type == #doIt) ifTrue:
[((s := self string) beginsWith: '----') ifFalse: [Compiler evaluate: s]].
(type == #classComment) ifTrue:
[ | cls | (cls := Smalltalk at: class asSymbol) comment: self text stamp: stamp.
Utilities noteMethodSubmission: #Comment forClass: cls ]]!
Item was changed:
----- Method: SystemDictionary>>cleanUpUndoCommands (in category 'shrinking') -----
cleanUpUndoCommands
"Smalltalk cleanUpUndoCommands" "<== print this to get classes involved"
+ | classes |
- | classes i p |
classes := Bag new.
'Ferreting out obsolete undo commands'
displayProgressAt: Sensor cursorPoint
from: 0 to: Morph withAllSubclasses size
during:
+ [:bar | | i | i := 0.
- [:bar | i := 0.
Morph withAllSubclassesDo:
[:c | bar value: (i := i+1).
c allInstancesDo:
+ [:m | | p | (p := m otherProperties) ifNotNil:
- [:m | (p := m otherProperties) ifNotNil:
[p keys do:
[:k | (p at: k) class == Command ifTrue:
[classes add: c name.
m removeProperty: k]]]]]].
^ classes!
Item was changed:
----- Method: SmalltalkImage>>fixObsoleteReferences (in category 'image cleanup') -----
fixObsoleteReferences
"SmalltalkImage current fixObsoleteReferences"
+
- | informee |
Smalltalk garbageCollect; garbageCollect.
+ Preference allInstances do: [:each | | informee |
- Preference allInstances do: [:each |
informee := each instVarNamed: #changeInformee.
((informee isKindOf: Behavior)
and: [informee isObsolete])
ifTrue: [
Transcript show: 'Preference: '; show: each name; cr.
each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]].
CompiledMethod allInstances do: [:method |
| obsoleteBindings |
obsoleteBindings := method literals select: [:literal |
literal isVariableBinding
and: [literal value isBehavior]
and: [literal value isObsolete]].
obsoleteBindings do: [:binding |
| obsName realName realClass |
obsName := binding value name.
Transcript show: 'Binding: '; show: obsName; cr.
realName := obsName copyReplaceAll: 'AnObsolete' with: ''.
realClass := Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject].
binding isSpecialWriteBinding
ifTrue: [binding privateSetKey: binding key value: realClass]
ifFalse: [binding key: binding key value: realClass]]].
Behavior flushObsoleteSubclasses.
Smalltalk garbageCollect; garbageCollect.
SystemNavigation default obsoleteBehaviors size > 0
ifTrue: [
SystemNavigation default obsoleteBehaviors inspect.
self error:'Still have obsolete behaviors. See inspector'].
!
Item was changed:
----- Method: Project>>serverList (in category 'file in/out') -----
serverList
+ | servers |
- | servers server |
"Take my list of server URLs and return a list of ServerDirectories to write on."
urlList isEmptyOrNil ifTrue: [^ nil].
servers := OrderedCollection new.
+ urlList do: [:url | | server |
- urlList do: [:url |
server := ServerDirectory serverForURL: url.
server ifNotNil: [servers add: server].
server := ServerDirectory serverForURL: url asUrl downloadUrl.
server ifNotNil: [servers add: server]].
^servers isEmpty
ifTrue: [nil]
ifFalse: [servers]!
Item was changed:
----- Method: Utilities class>>retrieveUrls:ontoQueue:withWaitSema: (in category 'fetching updates') -----
retrieveUrls: urls ontoQueue: queue withWaitSema: waitSema
"download the given list of URLs. The queue will be loaded alternately
with url's and with the retrieved contents. If a download fails, the
contents will be #failed. If all goes well, a special pair with an empty
URL and the contents #finished will be put on the queue. waitSema is
waited on every time before a new document is downloaded; this keeps
the downloader from getting too far ahead of the main process"
"kill the existing downloader if there is one"
+ | updateCounter |
- | doc canPeek front updateCounter |
UpdateDownloader
ifNotNil: [UpdateDownloader terminate].
updateCounter := 0.
"fork a new downloading process"
UpdateDownloader := [
'Downloading updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar |
urls
+ do: [:url | | front canPeek doc |
- do: [:url |
waitSema wait.
queue nextPut: url.
doc := HTTPClient httpGet: url.
doc isString
ifTrue: [queue nextPut: #failed.
UpdateDownloader := nil.
Processor activeProcess terminate]
ifFalse: [canPeek := 120 min: doc size.
front := doc next: canPeek. doc skip: -1 * canPeek.
(front beginsWith: '<!!DOCTYPE') ifTrue: [
(front includesSubString: 'Not Found') ifTrue: [
queue nextPut: #failed.
UpdateDownloader := nil.
Processor activeProcess terminate]]].
UpdateDownloader ifNotNil: [queue nextPut: doc. updateCounter := updateCounter + 1. bar value: updateCounter]]].
queue nextPut: ''.
queue nextPut: #finished.
UpdateDownloader := nil] newProcess.
UpdateDownloader priority: Processor userInterruptPriority.
"start the process running"
UpdateDownloader resume!
Item was changed:
----- Method: FilePackage>>fileInFrom: (in category 'reading') -----
fileInFrom: aStream
+ | changes |
- | chgRec changes |
changes := ChangeSet scanFile: aStream from: 0 to: aStream size.
aStream close.
('Processing ', self packageName)
displayProgressAt: Sensor cursorPoint
from: 1
to: changes size
+ during:[:bar| | chgRec |
- during:[:bar|
1 to: changes size do:[:i|
bar value: i.
chgRec := changes at: i.
self perform: (chgRec type copyWith: $:) asSymbol
with: chgRec.
].
].!
Item was changed:
----- Method: Project>>restoreReferences (in category 'file in/out') -----
restoreReferences
+
- | key newKey extName |
"I just came in from an exported segment. Take all my players that were in References, and reinstall them."
"*** Note that (world valueOfProperty: #References) is temporary during loading and is not the same as the global References dictionary (in Smalltalk)."
+ (world valueOfProperty: #References ifAbsent: [#()]) do: [:assoc | | key newKey extName | "just came in"
- (world valueOfProperty: #References ifAbsent: [#()]) do: [:assoc | "just came in"
key := assoc key.
(References includesKey: key)
ifTrue: ["must rename"
extName := assoc value externalName. "what user sees"
(References at: key) == assoc value ifTrue: [
self error: 'why is this object already present?'].
newKey := assoc value uniqueNameForReference.
References removeKey: newKey.
assoc key: newKey.
References add: assoc. "use the known association"
Preferences universalTiles
ifTrue: [assoc value renameTo: newKey] "change names in scripts"
ifFalse: [(assoc value renameInternal: extName) "keep externalName the same"
ifNil: [assoc value renameTo: newKey]].
"rename Project itself. Ignore others"
]
ifFalse: [References add: assoc]].
world removeProperty: #References.!
Item was changed:
----- Method: ChangeSet>>askAddedInstVars: (in category 'fileIn/Out') -----
askAddedInstVars: classList
+ | pairList pairClasses index pls |
- | pairList pairClasses index pls newStruct oldStruct |
"Ask the author whether these newly added inst vars need to be non-nil"
pairList := OrderedCollection new.
pairClasses := OrderedCollection new.
"Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here."
+ classList do: [:cls | | newStruct oldStruct |
- classList do: [:cls |
newStruct := (cls allInstVarNames).
oldStruct := (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst.
newStruct do: [:instVarName |
(oldStruct includes: instVarName) ifFalse: [
pairList add: cls name, ' ', instVarName.
pairClasses add: cls]]].
pairList isEmpty ifTrue: [^ #()].
[index := UIManager default
chooseFrom: pairList, #('all of these need a non-nil value'
'all of these are OK with a nil value')
title:
'These instance variables were added.
When an old project comes in, newly added
instance variables will have the value nil.
Click on items to remove them from the list.
Click on any for which nil is an OK value.'.
(index <= (pls := pairList size)) & (index > 0) ifTrue: [
pairList removeAt: index.
pairClasses removeAt: index].
index = (pls + 2) ifTrue: ["all are OK" ^ #()].
pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse.
^ pairClasses asSet asArray "non redundant"!
Item was changed:
----- Method: MczInstaller>>installMember: (in category 'installation') -----
installMember: member
+
- | str |
self useNewChangeSetDuring:
+ [ | str |str := member contentStream text.
- [str := member contentStream text.
str setConverterForCode.
str fileInAnnouncing: 'loading ', member fileName]!
Item was changed:
----- Method: SmartRefStream>>verifyStructure (in category 'read write') -----
verifyStructure
"Compare the incoming inst var name lists with the existing classes. Prepare tables that will help to restructure those who need it (renamed, reshaped, steady). If all superclasses are recorded in the file, only compare inst vars of this class, not of superclasses. They will get their turn. "
+ | converting |
- | newClass newList oldList converting |
self flag: #bobconv.
converting := OrderedCollection new.
+ structures keysDo: [:nm "an old className (symbol)" | | newClass newList oldList |
- structures keysDo: [:nm "an old className (symbol)" |
"For missing classes, there needs to be a method in SmartRefStream like
#rectangleoc2 that returns the new class."
newClass := self mapClass: nm. "does (renamed at: nm put: newClass name)"
newClass isString ifTrue: [^ newClass]. "error, fileIn needed"
newList := (Array with: newClass classVersion), (newClass allInstVarNames).
oldList := structures at: nm.
newList = oldList
ifTrue: [steady add: newClass] "read it in as written"
ifFalse: [converting add: newClass name]
].
false & converting isEmpty not ifTrue: ["debug"
self inform: 'These classes are being converted from existing methods:\' withCRs,
converting asArray printString].
!
Item was changed:
----- Method: ChangeSet class>>superclassOrder: (in category 'filein/out') -----
superclassOrder: classes
"Arrange the classes in the collection, classes, in superclass order so the
classes can be properly filed in. Do it in sets instead of ordered collections.
SqR 4/12/2000 22:04"
+ | all list inclusionSet cache |
- | all list aClass inclusionSet aClassIndex cache |
list := classes copy. "list is indexable"
inclusionSet := list asSet. cache := Dictionary new.
all := OrderedCollection new: list size.
list size timesRepeat:
+ [ | aClass aClassIndex |
- [
aClassIndex := list findFirst: [:one | one notNil and:
[self doWeFileOut: one given: inclusionSet cache: cache]].
aClass := list at: aClassIndex.
all addLast: aClass.
inclusionSet remove: aClass.
list at: aClassIndex put: nil
].
^all!
Item was changed:
----- Method: ChangeSet class>>scanFile:from:to: (in category 'scanning') -----
scanFile: file from: startPosition to: stopPosition
+ | changeList |
- | itemPosition item prevChar changeList |
changeList := OrderedCollection new.
file position: startPosition.
'Scanning ', file localName, '...'
displayProgressAt: Sensor cursorPoint
from: startPosition to: stopPosition
+ during: [:bar | | itemPosition item prevChar |
- during: [:bar |
[file position < stopPosition] whileTrue:[
bar value: file position.
[file atEnd not and: [file peek isSeparator]]
whileTrue: [prevChar := file next].
(file peekFor: $!!) ifTrue:[
(prevChar = Character cr or: [prevChar = Character lf])
ifTrue: [changeList addAll: (self scanCategory: file)].
] ifFalse:[
itemPosition := file position.
item := file nextChunk.
file skipStyleChunk.
item size > 0 ifTrue:[
changeList add: (ChangeRecord new file: file position: itemPosition type: #doIt).
].
].
]].
^changeList!
Item was changed:
----- Method: TextDiffBuilder>>incorporateRemovalsInto: (in category 'creating patches') -----
incorporateRemovalsInto: aPatchSequence
"Incorporate removals"
+
- | index |
removed ifNil:[^self].
+ removed do:[:assoc| | index |
- removed do:[:assoc|
index := assoc key.
self assert:[(aPatchSequence at: index) isNil].
aPatchSequence at: index put: #remove -> assoc value.
].
!
Item was changed:
----- Method: DeepCopier>>mapUniClasses (in category 'like fullCopy') -----
mapUniClasses
"For new Uniclasses, map their class vars to the new objects. And their additional class instance vars. (scripts slotInfo) and cross references like (player321)."
"Players also refer to each other using associations in the References dictionary. Search the methods of our Players for those. Make new entries in References and point to them."
+ | pp newKey |
- | pp oldPlayer newKey newAssoc oldSelList newSelList |
newUniClasses ifFalse: [^ self]. "All will be siblings. uniClasses is empty"
"Uniclasses use class vars to hold onto siblings who are referred to in code"
pp := Player class superclass instSize.
uniClasses do: [:playersClass | "values = new ones"
playersClass classPool associationsDo: [:assoc |
assoc value: (assoc value veryDeepCopyWith: self)].
playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self). "pp+1"
"(pp+2) slotInfo was deepCopied in copyUniClass and that's all it needs"
pp+3 to: playersClass class instSize do: [:ii |
playersClass instVarAt: ii put:
((playersClass instVarAt: ii) veryDeepCopyWith: self)].
].
"Make new entries in References and point to them."
+ References keys "copy" do: [:playerName | | oldPlayer |
- References keys "copy" do: [:playerName |
oldPlayer := References at: playerName.
(references includesKey: oldPlayer) ifTrue: [
newKey := (references at: oldPlayer) "new player" uniqueNameForReference.
"now installed in References"
(references at: oldPlayer) renameTo: newKey]].
+ uniClasses "values" do: [:newClass | | newSelList oldSelList |
- uniClasses "values" do: [:newClass |
oldSelList := OrderedCollection new. newSelList := OrderedCollection new.
newClass selectorsDo: [:sel |
+ (newClass compiledMethodAt: sel) literals do: [:assoc | | newAssoc |
- (newClass compiledMethodAt: sel) literals do: [:assoc |
assoc isVariableBinding ifTrue: [
(References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [
newKey := (references at: assoc value ifAbsent: [assoc value])
externalName asSymbol.
(assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [
newAssoc := References associationAt: newKey.
newClass methodDictionary at: sel put:
(newClass compiledMethodAt: sel) clone. "were sharing it"
(newClass compiledMethodAt: sel)
literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc)
put: newAssoc.
(oldSelList includes: assoc key) ifFalse: [
oldSelList add: assoc key. newSelList add: newKey]]]]]].
oldSelList with: newSelList do: [:old :new |
newClass replaceSilently: old to: new]]. "This is text replacement and can be wrong"!
Item was changed:
----- Method: Preferences class>>installHaloSpecsFromArray: (in category 'halos') -----
installHaloSpecsFromArray: anArray
+
- | aColor |
^ Parameters at: #HaloSpecs put:
(anArray collect:
+ [:quin | | aColor |
- [:quin |
aColor := Color.
quin fourth do: [:sel | aColor := aColor perform: sel].
HaloSpec new
horizontalPlacement: quin second
verticalPlacement: quin third
color: aColor
iconSymbol: quin fifth
addHandleSelector: quin first])!
Item was changed:
----- Method: ImageSegment>>smartFillRoots: (in category 'read/write segment') -----
smartFillRoots: dummy
+ | refs ours blockers known |
- | refs known ours ww blockers |
"Put all traced objects into my arrayOfRoots. Remove some
that want to be in outPointers. Return blockers, an
IdentityDictionary of objects to replace in outPointers."
blockers := dummy blockers.
known := (refs := dummy references) size.
refs keys do: [:obj | "copy keys to be OK with removing items"
(obj isSymbol) ifTrue: [refs removeKey: obj.
known := known-1].
(obj class == PasteUpMorph) ifTrue: [
obj isWorldMorph & (obj owner == nil) ifTrue: [
obj == dummy project world ifFalse: [
refs removeKey: obj. known := known-1.
blockers at: obj put:
(StringMorph
contents: 'The worldMorph of a different world')]]].
"Make a ProjectViewMorph here"
"obj class == Project ifTrue: [Transcript show: obj; cr]."
(blockers includesKey: obj) ifTrue: [
refs removeKey: obj ifAbsent: [known :=
known+1]. known := known-1].
].
ours := dummy project world.
+ refs keysDo: [:obj | | ww |
- refs keysDo: [:obj |
obj isMorph ifTrue: [
ww := obj world.
(ww == ours) | (ww == nil) ifFalse: [
refs removeKey: obj. known := known-1.
blockers at: obj put:
(StringMorph contents:
obj
printString, ' from another world')]]].
"keep original roots on the front of the list"
(dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []].
^ dummy rootObject, refs keys asArray.
!
Item was changed:
----- Method: SystemNavigation>>allUnusedClassesWithout: (in category 'query') -----
allUnusedClassesWithout: classesAndMessagesPair
"Enumerates all classes in the system and returns a list of those that are
apparently unused. A class is considered in use if it (a) has subclasses
or (b) is referred to by some method or (c) has its name in use as a
literal."
"SystemNavigation new unusedClasses"
+ | unused |
- | unused cl |
unused := Smalltalk classNames asIdentitySet
copyWithoutAll: (self allGlobalRefsWithout: classesAndMessagesPair).
^ unused
+ reject: [:cName | | cl |
- reject: [:cName |
cl := Smalltalk at: cName.
cl subclasses isEmpty not
or: [cl inheritsFrom: FileDirectory]]!
Item was changed:
----- Method: Project class>>versionForFileName: (in category 'utilities') -----
versionForFileName: version
"Project versionForFileName: 7"
+
+ ^String streamContents:[:s| | v |
- | v |
- ^String streamContents:[:s|
v := version printString.
v size < 3 ifTrue:[v := '0', v].
v size < 3 ifTrue:[v := '0', v].
s nextPutAll: v.
]
!
Item was changed:
----- Method: EventManager class>>flushEvents (in category 'initialize-release') -----
flushEvents
"Object flushEvents"
+
- | msgSet |
self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[
"make sure we don't modify evtDict while enumerating"
+ evtDict keys do:[:evtName| | msgSet |
- evtDict keys do:[:evtName|
msgSet := evtDict at: evtName ifAbsent:[nil].
(msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]].
EventManager actionMaps finalizeValues. !
Item was changed:
----- Method: SmalltalkImage>>saveImageSegments (in category 'sources, changes log') -----
saveImageSegments
+ | haveSegs oldImageSegDir |
- | haveSegs oldImageSegDir newImageSegDir |
haveSegs := false.
Smalltalk at: #ImageSegment ifPresent: [:theClass |
(haveSegs := theClass instanceCount ~= 0) ifTrue: [
oldImageSegDir := theClass segmentDirectory]].
haveSegs ifTrue: [
+ Smalltalk at: #ImageSegment ifPresent: [:theClass | | newImageSegDir |
- Smalltalk at: #ImageSegment ifPresent: [:theClass |
newImageSegDir := theClass segmentDirectory. "create the folder"
oldImageSegDir fileNames do: [:theName | "copy all segment files"
| imageSegmentName |
imageSegmentName := oldImageSegDir pathName, FileDirectory slash, theName.
newImageSegDir
copyFileWithoutOverwriteConfirmationNamed: imageSegmentName
toFileNamed: theName]]].
!
Item was changed:
----- Method: Project>>projectPreferenceAt: (in category 'project parameters') -----
projectPreferenceAt: aSymbol
"Answer the project preference stored at the given symbol. If there is none in the local preference dictionary, it must be because it was only latterly declared to be a project-local preference, so obtain its initial value instead from the last-known global or default setting"
+
- | aValue |
^ self projectPreferenceAt: aSymbol ifAbsent:
+ [ | aValue |
+ aValue := Preferences valueOfFlag: aSymbol.
- [aValue := Preferences valueOfFlag: aSymbol.
self projectPreferenceFlagDictionary at: aSymbol put: aValue.
^ aValue]!
Item was changed:
----- Method: SmalltalkImage>>stripMethods:messageCode: (in category 'utilities') -----
stripMethods: tripletList messageCode: messageString
"Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form (<class name> <#instance or #class> <selector name>), and with a string to be produced as part of the error msg if any of the methods affected is reached"
+
- | aClass sel keywords codeString |
tripletList do:
+ [:triplet | | codeString keywords aClass sel |
- [:triplet |
(aClass := (Smalltalk at: triplet first ifAbsent: [nil])) notNil ifTrue:
[triplet second == #class ifTrue:
[aClass := aClass class].
sel := triplet third.
keywords := sel keywords.
(keywords size == 1 and: [keywords first asSymbol isKeyword not])
ifTrue:
[codeString := keywords first asString]
ifFalse:
[codeString := ''.
keywords withIndexDo:
[:kwd :index |
codeString := codeString, ' ', (keywords at: index), ' ',
'arg', index printString]].
codeString := codeString, '
self codeStrippedOut: ', (messageString surroundedBySingleQuotes).
aClass compile: codeString classified: 'stripped']]!
Item was changed:
----- Method: Project>>installProjectPreferences (in category 'menu messages') -----
installProjectPreferences
"Install the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary"
+
- | localValue |
Preferences allPreferenceObjects do:
+ [:aPreference | | localValue |
- [:aPreference |
aPreference localToProject ifTrue:
[localValue := self projectPreferenceFlagDictionary at: aPreference name ifAbsent: [nil].
localValue ifNotNil:
[aPreference rawValue: localValue]]]!
Item was changed:
----- Method: FilePackage>>fromStream:named: (in category 'reading') -----
fromStream: aStream named: aName
+ | changes |
- | chgRec changes |
changes := ChangeSet scanFile: aStream from: 0 to: aStream size.
aStream close.
('Processing ', aName)
displayProgressAt: Sensor cursorPoint
from: 1
to: changes size
+ during:[:bar| | chgRec |
- during:[:bar|
1 to: changes size do:[:i|
bar value: i.
chgRec := changes at: i.
self perform: (chgRec type copyWith: $:) asSymbol
with: chgRec.
].
].!
Item was changed:
----- Method: Project>>compressFilesIn:to:in:resources: (in category 'file in/out') -----
compressFilesIn: tempDir to: localName in: localDirectory resources: collector
"Compress all the files in tempDir making up a zip file in localDirectory named localName"
+ | archive urlMap |
- | archive entry urlMap archiveName |
urlMap := Dictionary new.
collector locatorsDo:[:loc|
"map local file names to urls"
urlMap at: (tempDir localNameFor: loc localFileName) put: loc urlString.
ResourceManager cacheResource: loc urlString inArchive: localName].
archive := ZipArchive new.
+ tempDir fileNames do:[:fn| | archiveName entry |
- tempDir fileNames do:[:fn|
archiveName := urlMap at: fn ifAbsent:[fn].
entry := archive addFile: (tempDir fullNameFor: fn) as: archiveName.
entry desiredCompressionMethod: ZipArchive compressionStored.
].
archive writeToFileNamed: (localDirectory fullNameFor: localName).
archive close.
tempDir fileNames do:[:fn|
tempDir deleteFileNamed: fn ifAbsent:[]].
localDirectory deleteDirectory: tempDir localName.!
Item was changed:
----- Method: SpaceTally>>printSpaceAnalysis:on: (in category 'fileOut') -----
printSpaceAnalysis: threshold on: fileName
"SpaceTally new printSpaceAnalysis: 1000 on: 'STspace.text1'"
"sd-This method should be rewrote to be more coherent within the rest of the class
ie using preAllocate and spaceForInstanceOf:"
"If threshold > 0, then only those classes with more than that number
of instances will be shown, and they will be sorted by total instance space.
If threshold = 0, then all classes will appear, sorted by name."
+ | f totalCodeSpace totalInstCount totalInstSpace n totalPercent |
- | f codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n totalPercent percent |
Smalltalk garbageCollect.
totalCodeSpace := totalInstCount := totalInstSpace := n := 0.
results := OrderedCollection new: Smalltalk classNames size.
'Taking statistics...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
during: [:bar |
Smalltalk allClassesDo:
+ [:cl | | instSpace eltSize instCount codeSpace | codeSpace := cl spaceUsed.
- [:cl | codeSpace := cl spaceUsed.
bar value: (n := n+1).
Smalltalk garbageCollectMost.
instCount := cl instanceCount.
instSpace := (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8])*instCount. "Object headers"
cl isVariable
ifTrue: [eltSize := cl isBytes ifTrue: [1] ifFalse: [4].
cl allInstancesDo: [:x | instSpace := instSpace + (x basicSize*eltSize)]]
ifFalse: [instSpace := instSpace + (cl instSize*instCount*4)].
results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount: instCount spaceForInstances: instSpace).
totalCodeSpace := totalCodeSpace + codeSpace.
totalInstCount := totalInstCount + instCount.
totalInstSpace := totalInstSpace + instSpace]].
totalPercent := 0.0.
f := FileStream newFileNamed: fileName.
f timeStamp.
f nextPutAll: ('Class' padded: #right to: 30 with: $ );
nextPutAll: ('code space' padded: #left to: 12 with: $ );
nextPutAll: ('# instances' padded: #left to: 12 with: $ );
nextPutAll: ('inst space' padded: #left to: 12 with: $ );
nextPutAll: ('percent' padded: #left to: 8 with: $ ); cr.
threshold > 0 ifTrue:
["If inst count threshold > 0, then sort by space"
results := (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]])
asSortedCollection: [:s :s2 | s spaceForInstances > s2 spaceForInstances]].
results do:
+ [:s | | percent | f nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ );
- [:s | f nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ );
nextPutAll: (s codeSize printString padded: #left to: 12 with: $ );
nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ );
nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ).
percent := s spaceForInstances*100.0/totalInstSpace roundTo: 0.1.
totalPercent := totalPercent + percent.
percent >= 0.1 ifTrue:
[f nextPutAll: (percent printString padded: #left to: 8 with: $ )].
f cr].
f cr; nextPutAll: ('Total' padded: #right to: 30 with: $ );
nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ );
nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ );
nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ );
nextPutAll: ((totalPercent roundTo: 0.1) printString padded: #left to: 8 with: $ ).
f close!
Item was changed:
----- Method: ChangeSet>>methodsWithInitialsOtherThan: (in category 'moving changes') -----
methodsWithInitialsOtherThan: myInits
"Return a collection of method refs whose author appears to be different from the given one"
+ | slips |
- | slips method aTimeStamp |
slips := OrderedCollection new.
self changedClasses do:
[:aClass |
(self methodChangesAtClass: aClass name) associationsDo:
+ [:mAssoc | | aTimeStamp method | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
- [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
[method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
method ifNotNil:
[((aTimeStamp := Utilities timeStampForMethod: method) notNil and:
[(aTimeStamp beginsWith: myInits) not])
ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
^ slips
"Smalltalk browseMessageList: (ChangeSet current methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"!
Item was changed:
----- Method: NaturalLanguageTranslator>>scanFrom: (in category 'fileIn/fileOut') -----
scanFrom: aStream
"Read a definition of dictionary.
Make sure current locale corresponds my locale id"
+ | newTranslations currentPlatform |
- | aString newTranslations assoc currentPlatform |
newTranslations := Dictionary new.
currentPlatform := Locale currentPlatform.
+ [ | aString assoc |
+ Locale
- [Locale
currentPlatform: (Locale localeID: id).
[aString := aStream nextChunk withSqueakLineEndings.
aString size > 0]
whileTrue: [assoc := Compiler evaluate: aString.
assoc value = ''
ifTrue: [self class registerPhrase: assoc key]
ifFalse: [newTranslations add: assoc]]]
ensure: [Locale currentPlatform: currentPlatform].
self mergeTranslations: newTranslations!
Item was changed:
----- Method: SystemNavigation>>allPrimitiveMethodsInCategories: (in category 'query') -----
allPrimitiveMethodsInCategories: aList
"Answer an OrderedCollection of all the methods that are implemented by
primitives in the given categories. 1/26/96 sw"
"SystemNavigation new allPrimitiveMethodsInCategories:
#('Collections-Streams' 'Files-Streams' 'Files-Abstract' 'Files-Macintosh')"
+ | aColl |
- | aColl method |
aColl := OrderedCollection new: 200.
Cursor execute
showWhile: [self
allBehaviorsDo: [:aClass | (aList includes: (SystemOrganization categoryOfElement: aClass theNonMetaClass name asString) asString)
ifTrue: [aClass
+ selectorsDo: [:sel | | method |
- selectorsDo: [:sel |
method := aClass compiledMethodAt: sel.
method primitive ~= 0
ifTrue: [aColl addLast: aClass name , ' ' , sel , ' ' , method primitive printString]]]]].
^ aColl!
Item was changed:
----- Method: SARInstaller>>fileInMonticelloPackageNamed: (in category 'client services') -----
fileInMonticelloPackageNamed: memberName
"This is to be used from preamble/postscript code to file in zip
members as Monticello packages (.mc)."
+ | member file mcPackagePanel mcRevisionInfo mcSnapshot mcFilePackageManager mcPackage mcBootstrap newCS |
- | member file mcPackagePanel mcRevisionInfo mcSnapshot mcFilePackageManager mcPackage info snapshot newCS mcBootstrap |
mcPackagePanel := Smalltalk at: #MCPackagePanel ifAbsent: [ ].
mcRevisionInfo := Smalltalk at: #MCRevisionInfo ifAbsent: [ ].
mcSnapshot := Smalltalk at: #MCSnapshot ifAbsent: [ ].
mcFilePackageManager := Smalltalk at: #MCFilePackageManager ifAbsent: [ ].
mcPackage := Smalltalk at: #MCPackage ifAbsent: [ ].
member := self memberNamed: memberName.
member ifNil: [ ^self errorNoSuchMember: memberName ].
"We are missing MCInstaller, Monticello and/or MonticelloCVS.
If the bootstrap is present, use it. Otherwise interact with the user."
({ mcPackagePanel. mcRevisionInfo. mcSnapshot. mcFilePackageManager. mcPackage } includes: nil)
ifTrue: [
mcBootstrap := self getMCBootstrapLoaderClass.
mcBootstrap ifNotNil: [ ^self fileInMCVersion: member withBootstrap: mcBootstrap ].
(self confirm: ('Monticello support is not installed, but must be to load member named ', memberName, '.
Load it from SqueakMap?'))
ifTrue: [ self class loadMonticello; loadMonticelloCVS.
^self fileInMonticelloPackageNamed: memberName ]
ifFalse: [ ^false ] ].
member extractToFileNamed: member localFileName inDirectory: self directory.
file := (Smalltalk at: #MCFile)
name: member localFileName
directory: self directory.
+ self class withCurrentChangeSetNamed: file name do: [ :cs | | snapshot info |
- self class withCurrentChangeSetNamed: file name do: [ :cs |
newCS := cs.
file readStreamDo: [ :stream |
info := mcRevisionInfo readFrom: stream nextChunk.
snapshot := mcSnapshot fromStream: stream ].
snapshot install.
(mcFilePackageManager forPackage:
(mcPackage named: info packageName))
file: file
].
newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ].
mcPackagePanel allSubInstancesDo: [ :ea | ea refresh ].
World doOneCycle.
self installed: member.
!
Item was changed:
----- Method: SystemNavigation>>allMethodsWithSourceString:matchCase: (in category 'query') -----
allMethodsWithSourceString: aString matchCase: caseSensitive
"Answer a SortedCollection of all the methods that contain, in source code, aString as a substring. Search the class comments also"
+ | list adder |
- | list count adder |
list := Set new.
adder := [ :mrClass :mrSel | list add: ( MethodReference new
setStandardClass: mrClass
methodSymbol: mrSel)].
'Searching all source code...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
+ during: [:bar | | count |
- during: [:bar |
count := 0.
SystemNavigation default allBehaviorsDo: [:each |
bar value: (count := count + 1).
each selectorsDo: [:sel |
((each sourceCodeAt: sel) findString: aString
startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [
sel isDoIt ifFalse: [adder value: each value: sel]]].
(each organization classComment asString findString: aString
startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [
adder value: each value: #Comment] ]].
^ list asSortedCollection!
Item was changed:
----- Method: Project>>localeID (in category 'language') -----
localeID
"Answer the natural language for the project"
+
- | prev |
^ self projectParameterAt: #localeID
+ ifAbsentPut: [ | prev |
- ifAbsentPut: [
(prev := self previousProject)
ifNotNil: [prev projectParameterAt: #localeID ifAbsent: [LocaleID current]]
ifNil: [LocaleID current]]!
Item was changed:
----- Method: Utilities class>>createPageTestWorkspace (in category 'miscellaneous') -----
createPageTestWorkspace
"Used to generate a workspace window for testing page up and page down stuff."
"Utilities createPageTestWorkspace"
+ | numberOfLines maxStringLength minLineCounterSize lineCounterSize offsetSize stream headerConstant prevStart prevStrLen prevLineNumber |
- | numberOfLines maxStringLength minLineCounterSize lineCounterSize offsetSize stream headerConstant prevStart prevStrLen prevLineNumber stringLen lineNumber start log pad charIndex char |
numberOfLines := 400.
maxStringLength := 22.
minLineCounterSize := 3.
lineCounterSize := (numberOfLines log asInteger + 1) max: minLineCounterSize.
offsetSize := 5.
stream := ReadWriteStream on: ''.
headerConstant := lineCounterSize + 1 + offsetSize + 1.
prevStart := headerConstant negated.
prevStrLen := 0.
prevLineNumber := 0.
+ numberOfLines timesRepeat: [ | log stringLen pad lineNumber charIndex start |
- numberOfLines timesRepeat: [
stringLen := maxStringLength atRandom max: 1.
lineNumber := prevLineNumber + 1.
start := prevStart + prevStrLen + headerConstant + 1.
prevStart := start.
prevStrLen := stringLen.
prevLineNumber := lineNumber.
log := lineNumber log asInteger.
pad := lineCounterSize - log - 1.
pad timesRepeat: [stream nextPutAll: '0'].
stream nextPutAll: lineNumber printString.
stream space.
log := start log asInteger.
pad := offsetSize - log - 1.
pad timesRepeat: [stream nextPutAll: '0'].
stream nextPutAll: start printString.
stream space.
charIndex := 'a' first asInteger.
+ stringLen timesRepeat: [ | char |
- stringLen timesRepeat: [
char := Character value: charIndex.
charIndex := charIndex + 1.
stream nextPut: char].
lineNumber = numberOfLines ifFalse: [stream cr]
].
UIManager default edit: stream contents label: 'Test Data'.
!
Item was changed:
----- Method: ChangeSet>>changedMessageList (in category 'method changes') -----
changedMessageList
"Used by a message set browser to access the list view information."
+ | messageList |
- | messageList classNameInFull classNameInParts |
messageList := OrderedCollection new.
+ changeRecords associationsDo: [:clAssoc | | classNameInParts classNameInFull |
- changeRecords associationsDo: [:clAssoc |
classNameInFull := clAssoc key asString.
classNameInParts := classNameInFull findTokens: ' '.
(clAssoc value allChangeTypes includes: #comment) ifTrue:
[messageList add:
(MethodReference new
setClassSymbol: classNameInParts first asSymbol
classIsMeta: false
methodSymbol: #Comment
stringVersion: classNameInFull, ' Comment')].
clAssoc value methodChangeTypes associationsDo: [:mAssoc |
(#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
[messageList add:
(MethodReference new
setClassSymbol: classNameInParts first asSymbol
classIsMeta: classNameInParts size > 1
methodSymbol: mAssoc key
stringVersion: classNameInFull, ' ' , mAssoc key)]]].
^ messageList asSortedArray!
Item was changed:
----- Method: SystemDictionary>>testFormatter (in category 'housekeeping') -----
testFormatter
"Smalltalk testFormatter"
"Reformats the source for every method in the system, and
then compiles that source and verifies that it generates
identical code. The formatting used will be either classic
monochrome or fancy polychrome, depending on the setting
of the preference #colorWhenPrettyPrinting."
"Note: removed references to Preferences colorWhenPrettyPrinting and replaced them simply with false, as I've been removing this preference lately. --Ron Spengler 8/23/09"
+ | badOnes |
- | newCodeString methodNode oldMethod newMethod badOnes n |
badOnes := OrderedCollection new.
self forgetDoIts.
'Formatting all classes...'
displayProgressAt: Sensor cursorPoint
from: 0
to: CompiledMethod instanceCount
during:
+ [:bar | | n |
- [:bar |
n := 0.
self systemNavigation allBehaviorsDo:
[:cls |
"Transcript cr; show: cls name."
cls selectorsDo:
+ [:selector | | newMethod newCodeString methodNode oldMethod |
- [:selector |
(n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
newCodeString := cls prettyPrinterClass
format: (cls sourceCodeAt: selector)
in: cls
notifying: nil
decorated: false.
methodNode := cls compilerClass new
compile: newCodeString
in: cls
notifying: nil
ifFail: [].
newMethod := methodNode generate.
oldMethod := cls compiledMethodAt: selector.
oldMethod = newMethod
ifFalse:
[Transcript
cr;
show: '***' , cls name , ' ' , selector.
badOnes add: cls name , ' ' , selector]]]].
self systemNavigation browseMessageList: badOnes asSortedCollection
name: 'Formatter Discrepancies'!
Item was changed:
----- Method: SystemVersion class>>parseVersionString: (in category 'accessing') -----
parseVersionString: versionString
"Answer the version of this release as version, date, update."
"SystemVersion parseVersionString: 'Squeak3.1alpha of 28 February 2001 [latest update: #3966]' "
+ | version date update |
- | stream version date update |
+ [ | stream |
+ stream := ReadStream on: versionString.
- [stream := ReadStream on: versionString.
version := stream upToAll: ' of '.
date := Date readFrom: stream.
stream upToAll: ' #'.
update := Number readFrom: stream]
on: Error
do: [^nil].
^{version. date. update.}!
Item was changed:
----- Method: MidiPrimTester>>getInputForSeconds:onPort: (in category 'tests') -----
getInputForSeconds: seconds onPort: portNum
"Collect MIDI input from the given port for the given number of seconds, and answer a string describing the data read."
"MidiPrimTester new getInputForSeconds: 5 onPort: 0"
+ | s bufList midiStartTime |
- | buf bufList endTime n midiStartTime s t |
"collect the data"
+ self openPort: portNum andDo: [ | endTime buf n |
- self openPort: portNum andDo: [
buf := ByteArray new: 1000.
bufList := OrderedCollection new.
midiStartTime := self primMIDIGetClock.
endTime := Time millisecondClockValue + (seconds * 1000).
[Time millisecondClockValue < endTime] whileTrue: [
n := self primMIDIReadPort: portNum into: buf.
n > 0 ifTrue: [bufList add: (buf copyFrom: 1 to: n)].
(Delay forMilliseconds: 5) wait]].
"format the data into a string"
s := WriteStream on: String new.
s cr.
+ bufList do: [:b | | t |
- bufList do: [:b |
t := (self bufferTimeStampFrom: b) - midiStartTime.
s print: t.
s nextPutAll: ': '.
5 to: b size do: [:i | s print: (b at: i); space].
s cr].
^ s contents
!
Item was changed:
----- Method: SmartRefStream>>conversionMethodsFor: (in category 'class changed shape') -----
conversionMethodsFor: classList
+ | list |
- | oldStruct newStruct list |
"Each of these needs a conversion method. Hard part is the comment in it. Return a MessageSet."
list := OrderedCollection new.
+ classList do: [:cls | | oldStruct newStruct |
- classList do: [:cls |
oldStruct := structures at: cls name ifAbsent: [#()].
newStruct := (Array with: cls classVersion), (cls allInstVarNames).
self writeConversionMethodIn: cls fromInstVars: oldStruct to: newStruct
renamedFrom: nil.
list add: cls name, ' convertToCurrentVersion:refStream:'.
].
^list.!
Item was changed:
----- Method: ImageSegment class>>swapOutInactiveClasses (in category 'testing') -----
swapOutInactiveClasses "ImageSegment swapOutInactiveClasses"
"Make up segments by grouping unused classes by system category.
Read about, and execute discoverActiveClasses, and THEN execute this one."
+ | unused groups |
- | unused groups i roots |
ImageSegment recoverFromMDFault.
ImageSegmentRootStub recoverFromMDFault.
unused := Smalltalk allClasses select: [:c | (c instVarNamed: 'methodDict') == nil].
unused do: [:c | c recoverFromMDFault].
groups := Dictionary new.
SystemOrganization categories do:
+ [:cat | | i |
- [:cat |
i := (cat findLast: [:c | c = $-]) - 1.
i <= 0 ifTrue: [i := cat size].
groups at: (cat copyFrom: 1 to: i)
put: (groups at: (cat copyFrom: 1 to: i) ifAbsent: [Array new]) ,
((SystemOrganization superclassOrder: cat) select: [:c |
unused includes: c]) asArray].
groups keys do:
+ [:cat | | roots | roots := groups at: cat.
- [:cat | roots := groups at: cat.
Transcript cr; cr; show: cat; cr; print: roots; endEntry.
roots := roots , (roots collect: [:c | c class]).
(cat beginsWith: 'Sys' "something here breaks") ifFalse:
[(ImageSegment new copyFromRoots: roots sizeHint: 0) extract;
writeToFile: cat].
Transcript cr; print: Smalltalk garbageCollect; endEntry]!
Item was changed:
----- Method: SystemNavigation>>allCallsOn:and: (in category 'query') -----
allCallsOn: firstLiteral and: secondLiteral
"Answer a SortedCollection of all the methods that call on both aLiteral
and secondLiteral."
+ | aCollection firstSpecial secondSpecial firstByte secondByte |
- | aCollection secondArray firstSpecial secondSpecial firstByte secondByte |
self flag: #ShouldUseAllCallsOn:. "sd"
aCollection := SortedCollection new.
firstSpecial := Smalltalk hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte := b].
secondSpecial := Smalltalk hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte := b].
Cursor wait showWhile: [
+ self allBehaviorsDo: [:class | | secondArray |
- self allBehaviorsDo: [:class |
secondArray := class
whichSelectorsReferTo: secondLiteral
special: secondSpecial
byte: secondByte.
((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select:
[:aSel | (secondArray includes: aSel)]) do:
[:sel |
aCollection add: (
MethodReference new
setStandardClass: class
methodSymbol: sel
)
]
]
].
^aCollection!
Item was changed:
----- Method: SystemDictionary>>abandonTempNames (in category 'shrinking') -----
abandonTempNames
"Replaces every method by a copy with no source pointer or
encoded temp names."
"Smalltalk abandonTempNames"
+ | continue oldMethods newMethods n |
- | continue oldMethods newMethods n m |
continue := self confirm: '-- CAUTION --
If you have backed up your system and
are prepared to face the consequences of
abandoning all source code, hit Yes.
If you have any doubts, hit No,
to back out with no harm done.'.
continue
ifFalse: [^ self inform: 'Okay - no harm done'].
self forgetDoIts; garbageCollect.
oldMethods := OrderedCollection new.
newMethods := OrderedCollection new.
n := 0.
'Removing temp names to save space...'
displayProgressAt: Sensor cursorPoint
from: 0
to: CompiledMethod instanceCount
during: [:bar | self systemNavigation
+ allBehaviorsDo: [:cl | cl selectorsDo: [:sel | | m |
- allBehaviorsDo: [:cl | cl selectorsDo: [:sel |
bar value: (n := n + 1).
m := cl compiledMethodAt: sel.
oldMethods addLast: m.
newMethods
addLast: (m copyWithTrailerBytes: #(0 ))]]].
oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
SmalltalkImage current closeSourceFiles.
self flag: #shouldUseAEnsureBlockToBeSureThatTheFileIsClosed.
"sd: 17 April 2003"
Preferences disable: #warnIfNoChangesFile.
Preferences disable: #warnIfNoSourcesFile!
Item was changed:
----- Method: ImageSegment class>>reclaimObsoleteSegmentFiles (in category 'fileIn/Out') -----
reclaimObsoleteSegmentFiles "ImageSegment reclaimObsoleteSegmentFiles"
"Delete segment files that can't be used after this image is saved.
Note that this is never necessary -- it just saves file space."
+ | segDir segFiles folderName byName exists |
- | aFileName segDir segFiles folderName byName exists |
folderName := FileDirectory default class localNameFor: self folder.
(FileDirectory default includesKey: folderName) ifFalse: [
^ self "don't create if absent"].
segDir := self segmentDirectory.
segFiles := (segDir fileNames select: [:fn | fn endsWith: '.seg']) asSet.
exists := segFiles copy.
segFiles isEmpty ifTrue: [^ self].
byName := Set new.
"Remove (save) every file owned by a segment in memory"
+ ImageSegment allInstancesDo: [:is | | aFileName |
- ImageSegment allInstancesDo: [:is |
(aFileName := is localName) ifNotNil: [
segFiles remove: aFileName ifAbsent: [].
(exists includes: aFileName) ifFalse: [
Transcript cr; show: 'Segment file not found: ', aFileName].
byName add: is segmentName]].
"Of the segments we have seen, delete unclaimed the files."
segFiles do: [:fName |
"Delete other file versions with same project name as one known to us"
(byName includes: (fName sansPeriodSuffix stemAndNumericSuffix first))
ifTrue: [segDir deleteFileNamed: fName]].!
Item was changed:
----- Method: SpaceTally>>spaceForInstancesOf:withInstanceCount: (in category 'instance size') -----
spaceForInstancesOf: aClass withInstanceCount: instCount
"Answer the number of bytes consumed by all instances of the given class, including their object headers."
+ | isCompact instVarBytes bytesPerElement headerBytes total |
- | isCompact instVarBytes bytesPerElement contentBytes headerBytes total |
instCount = 0 ifTrue: [^ 0].
isCompact := aClass indexIfCompact > 0.
instVarBytes := aClass instSize * 4.
aClass isVariable
ifTrue: [
bytesPerElement := aClass isBytes ifTrue: [1] ifFalse: [4].
total := 0.
+ aClass allInstancesDo: [:inst | | contentBytes |
- aClass allInstancesDo: [:inst |
contentBytes := instVarBytes + (inst size * bytesPerElement).
headerBytes :=
contentBytes > 255
ifTrue: [12]
ifFalse: [isCompact ifTrue: [4] ifFalse: [8]].
total := total + headerBytes + contentBytes].
^ total]
ifFalse: [
headerBytes :=
instVarBytes > 255
ifTrue: [12]
ifFalse: [isCompact ifTrue: [4] ifFalse: [8]].
^ instCount * (headerBytes + instVarBytes)].
!
Item was changed:
----- Method: TextDiffBuilder>>stringHashBlock (in category 'private') -----
stringHashBlock
"Return a block for use in string hashing"
+
+ ^[:string| | stringSize |
- | stringSize |
- ^[:string|
stringSize := string size.
stringSize = 0
ifTrue:[0]
ifFalse:[ stringSize < 3
ifTrue:[(string at: 1) asInteger +
((string at: string size) asInteger bitShift: 8)]
ifFalse:[ (string at: 1) asInteger +
((string at: stringSize // 3 + 1) asInteger bitShift: 4) +
((string at: stringSize // 2 + 1) asInteger bitShift: 8) +
((string at: stringSize * 2 // 3 + 1) asInteger bitShift: 12) +
((string at: stringSize) asInteger bitShift: 16)]]] fixTemps!
Item was changed:
----- Method: HTTPClient class>>pluginHttpPostMultipart:args: (in category 'private') -----
pluginHttpPostMultipart: url args: argsDict
+ | mimeBorder argsStream crLf resultStream result |
- | mimeBorder argsStream crLf fieldValue resultStream result |
" do multipart/form-data encoding rather than x-www-urlencoded "
crLf := String crlf.
mimeBorder := '----squeak-', Time millisecondClockValue printString, '-stuff-----'.
"encode the arguments dictionary"
argsStream := WriteStream on: String new.
argsDict associationsDo: [:assoc |
+ assoc value do: [ :value | | fieldValue |
- assoc value do: [ :value |
"print the boundary"
argsStream nextPutAll: '--', mimeBorder, crLf.
" check if it's a non-text field "
argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'.
(value isKindOf: MIMEDocument)
ifFalse: [fieldValue := value]
ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType.
fieldValue := (value content
ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile]
ifNotNil: [value content]) asString].
" Transcript show: 'field=', key, '; value=', fieldValue; cr. "
argsStream nextPutAll: crLf, crLf, fieldValue, crLf.
]].
argsStream nextPutAll: '--', mimeBorder, '--'.
resultStream := FileStream
post:
('ACCEPT: text/html', crLf,
'User-Agent: Squeak 3.1', crLf,
'Content-type: multipart/form-data; boundary=', mimeBorder, crLf,
'Content-length: ', argsStream contents size printString, crLf, crLf,
argsStream contents)
url: url ifError: [^'Error in post ' url asString].
"get the header of the reply"
result := resultStream
ifNil: ['']
ifNotNil: [resultStream upToEnd].
^MIMEDocument content: result!
Item was changed:
----- Method: ImageSegment>>comeFullyUpOnReload: (in category 'fileIn/Out') -----
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 ccFixups receiverClasses rootsToUnhiberhate myProject |
- | mapFakeClassesToReal ccFixups receiverClasses
- rootsToUnhiberhate myProject existing |
RecentlyRenamedClasses := nil. "in case old data
hanging around"
mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers.
"Dictionary of just the ones that change shape.
Substitute them in outPointers."
ccFixups := self remapCompactClasses: mapFakeClassesToReal
refStrm: smartRefStream.
ccFixups ifFalse: [^ self error: 'A class in the file is not
compatible'].
endMarker := segment nextObject. "for enumeration of objects"
endMarker == 0 ifTrue: [endMarker := 'End' clone].
self fixCapitalizationOfSymbols.
arrayOfRoots := self loadSegmentFrom: segment outPointers: outPointers.
"Can't use install. Not ready for rehashSets"
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 | | existing |
- 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 isKindOf: TTCFontSet) ifTrue: [
existing := TTCFontSet familyName:
importedObject familyName
pointSize:
importedObject pointSize. "supplies default"
existing == importedObject ifFalse:
[importedObject becomeForward: existing].
].
].
"Smalltalk garbageCollect. MultiSymbol rehash. These take
time and are not urgent, so don't to them. In the normal case, no
bad MultiSymbols will be found."
receiverClasses := self restoreEndianness. "rehash sets"
smartRefStream checkFatalReshape: receiverClasses.
"Classes in this segment."
arrayOfRoots do: [:importedObject |
importedObject class class == Metaclass ifTrue: [self
declare: importedObject]].
arrayOfRoots do: [:importedObject |
(importedObject isKindOf: CompiledMethod) ifTrue: [
importedObject sourcePointer > 0 ifTrue:
[importedObject zapSourcePointer]].
(importedObject isKindOf: Project) ifTrue: [
myProject := importedObject.
importedObject ensureChangeSetNameUnique.
Project addingProject: importedObject.
importedObject restoreReferences.
self dependentsRestore: importedObject.
ScriptEditorMorph writingUniversalTiles:
((importedObject projectPreferenceAt:
#universalTiles) ifNil: [false])]].
rootsToUnhiberhate := arrayOfRoots select: [:importedObject |
importedObject respondsTo: #unhibernate
"ScriptEditors and ViewerFlapTabs"
].
myProject ifNotNil: [
myProject world setProperty: #thingsToUnhibernate
toValue: rootsToUnhiberhate
].
mapFakeClassesToReal isEmpty ifFalse: [
mapFakeClassesToReal keys do: [:aFake |
aFake indexIfCompact > 0 ifTrue: [aFake
becomeUncompact].
aFake removeFromSystemUnlogged].
SystemOrganization removeEmptyCategories].
"^ self"
!
Item was changed:
----- Method: ImageSegment class>>activeClassesByCategory (in category 'testing') -----
activeClassesByCategory "ImageSegment activeClassesByCategory"
"Return a dictionary of active classes by system category.
Useful for finding kernel categories to minimize swapping."
+ | active dict |
- | active dict cat list |
active := self activeClasses.
dict := Dictionary new.
active do:
+ [:c | | cat list | cat := c category.
- [:c | cat := c category.
list := dict at: cat ifAbsent: [Array new].
dict at: cat put: (list copyWith: c)].
^ dict
"
ImageSegment discoverActiveClasses <-- do it
-- do something typical --
ImageSegment activeClassesByCategory <-- inspect it
"!
Item was changed:
----- Method: SystemDictionary>>reconstructChanges (in category 'housekeeping') -----
reconstructChanges
"Move all the changes and its histories onto another sources file."
"Smalltalk reconstructChanges"
+ | f oldChanges |
- | f oldChanges classCount |
f := FileStream fileNamed: 'ST80.temp'.
f header; timeStamp.
'Condensing Changes File...'
displayProgressAt: Sensor cursorPoint
from: 0 to: self classNames size + self traitNames size
during:
+ [:bar | | classCount | classCount := 0.
- [:bar | classCount := 0.
Smalltalk allClassesAndTraitsDo:
[:classOrTrait | bar value: (classCount := classCount + 1).
classOrTrait moveChangesWithVersionsTo: f.
classOrTrait putClassCommentToCondensedChangesFile: f.
classOrTrait classSide moveChangesWithVersionsTo: f]].
SmalltalkImage current lastQuitLogPosition: f position.
f trailer; close.
oldChanges := SourceFiles at: 2.
oldChanges close.
FileDirectory default
deleteFileNamed: oldChanges name , '.old';
rename: oldChanges name toBe: oldChanges name , '.old';
rename: f name toBe: oldChanges name.
self setMacFileInfoOn: oldChanges name.
SourceFiles at: 2
put: (FileStream oldFileNamed: oldChanges name)!
Item was changed:
----- Method: MessageTally>>spyEvery:onProcess:forMilliseconds: (in category 'initialize-release') -----
spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration
"Create a spy and spy on the given process at the specified rate."
+ | myDelay time0 endTime sem observedProcess |
- | myDelay startTime time0 endTime sem observedProcess |
(aProcess isKindOf: Process)
ifFalse: [self error: 'spy needs a Process here'].
self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method.
"set up the probe"
observedProcess := aProcess.
myDelay := Delay forMilliseconds: millisecs.
time0 := Time millisecondClockValue.
endTime := time0 + msecDuration.
sem := Semaphore new.
gcStats := SmalltalkImage current getVMParameters.
+ Timer := [ | startTime |
- Timer := [
[
startTime := Time millisecondClockValue.
myDelay wait.
self tally: Processor preemptedProcess suspendedContext
in: (ShowProcesses ifTrue: [
observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil]])
"tally can be > 1 if ran a long primitive"
by: (Time millisecondClockValue - startTime) // millisecs.
startTime < endTime
] whileTrue.
sem signal.
] newProcess.
Timer priority: Processor timingPriority-1.
"activate the probe and evaluate the block"
Timer resume.
"activate the probe and wait for it to finish"
sem wait.
"Collect gc statistics"
SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal |
gcStats at: idx put: (gcVal - gcStats at: idx)].
time := Time millisecondClockValue - time0!
More information about the Packages
mailing list