"{ Package: 'stx:libtool2' }"

Object subclass:#SnapShotImage

	instanceVariableNames:'memory globals'

	classVariableNames:''

	poolDictionaries:''

	category:'System-Support'

!

!SnapShotImage class methodsFor:'documentation'!

documentation

"

    I simulate a Smalltalk environment as present in a snapshot image.

    My protocol mimics the NameSpace (i.e. class-environment) protocol,

    and I can be used as a Browsers environment, in order to open a

    browser into an old snapShot image (st.img - file).

    I am not used directly; instead, via the SystemBrowsers entry:

        SystemBrowser openOnSnapShotImage:'/export/home/cg/work/stx/projects/smalltalk/st.img'

    [author:]

        Claus Gittinger

"

! !

!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$'

! !