"{ Package: 'stx:libtool' }"

Object subclass:#SnapShotImage
	instanceVariableNames:'memory globals'
	classVariableNames:''
	poolDictionaries:''
	category:'System-Support'
!


!SnapShotImage class methodsFor:'instance creation'!

for:aFilename
    ^ self new for:aFilename
! !

!SnapShotImage methodsFor:'private'!

fetchGlobals
    globals := IdentityDictionary new.
    memory globalEntries do:[:eachEntry |
        |nameSymRef valRef nameSym value|

        nameSymRef := eachEntry key.
        valRef := eachEntry value.
        nameSymRef isImageSymbol ifFalse:[self halt].

        nameSym := (memory printStringOfSymbol:nameSymRef) asSymbol.
        globals at:nameSym put:valRef
    ].
!

for:aFilename
    memory := SnapShotImageMemory for:aFilename.
    memory image:self.
    memory readHeader! !

!SnapShotImage methodsFor:'smalltalk protocol'!

allClassesDo:aBlock
    self keysAndValuesDo:[:key :valRef |
        valRef isInteger ifFalse:[
            valRef ~~ true ifTrue:[
                valRef ~~ false ifTrue:[
                    valRef notNil ifTrue:[
                        valRef isImageBehavior ifTrue:[
                            aBlock value:valRef
                        ]
                    ]
                ]
            ]
        ]
    ].
!

allClassesInCategory:aCategory
    |coll|

    coll := OrderedCollection new.
    self allClassesInCategory:aCategory do:[:aClass |
        coll add:aClass
    ].
    ^ coll!

allClassesInCategory:aCategory do:aBlock
    "evaluate the argument, aBlock for all classes in the aCategory;
     The order of the classes is not defined."

    aCategory notNil ifTrue:[
        self allClassesDo:[:aClass |
            aClass isMeta ifFalse:[
                (aClass category = aCategory) ifTrue:[
                    aBlock value:aClass
                ]
            ]
        ]
    ]!

at:aKey
    globals isNil ifTrue:[
        self fetchGlobals
    ].
    ^ globals at:aKey
!

at:aKey ifAbsent:exceptionValue
    globals isNil ifTrue:[
        self fetchGlobals
    ].
    ^ globals at:aKey ifAbsent:exceptionValue!

keysAndValuesDo:aTwoArgBlock
    globals isNil ifTrue:[
        self fetchGlobals
    ].
    globals keysAndValuesDo:aTwoArgBlock
! !

!SnapShotImage class methodsFor:'documentation'!

version
    ^ '$Header$'
! !