cg@1448: "{ Package: 'stx:libtool2' }"
cg@1415: 
cg@1415: Object subclass:#SnapShotImage
cg@1482: 	instanceVariableNames:'memory globals cachedBehaviors'
cg@1415: 	classVariableNames:''
cg@1415: 	poolDictionaries:''
cg@1415: 	category:'System-Support'
cg@1415: !
cg@1415: 
cg@1448: !SnapShotImage class methodsFor:'documentation'!
cg@1448: 
cg@1448: documentation
cg@1448: "
cg@1448:     I simulate a Smalltalk environment as present in a snapshot image.
cg@1448:     My protocol mimics the NameSpace (i.e. class-environment) protocol,
cg@1448:     and I can be used as a Browsers environment, in order to open a
cg@1448:     browser into an old snapShot image (st.img - file).
cg@1448: 
cg@1448:     I am not used directly; instead, via the SystemBrowsers entry:
cg@1448:         SystemBrowser openOnSnapShotImage:'/export/home/cg/work/stx/projects/smalltalk/st.img'
cg@1448: 
cg@1483:         SystemBrowser openOnSnapShotImage:'st.img'
cg@1483: 
cg@1483:     This enables a standard browser to peek into a snapshot image... (well, almost)
cg@1483: 
cg@1448:     [author:]
cg@1448:         Claus Gittinger
cg@1448: "
cg@1470: !
cg@1470: 
cg@1470: examples
cg@1470: "
cg@1470:     |i m|
cg@1470: 
cg@1470:     i := self for:'st.img'.
cg@1470:     m := i memory.
cg@1470:     m  fetchObjectAt:16r38000000
cg@1470: "
cg@1448: ! !
cg@1415: 
cg@1415: !SnapShotImage class methodsFor:'instance creation'!
cg@1415: 
cg@1415: for:aFilename
cg@1415:     ^ self new for:aFilename
cg@1415: ! !
cg@1415: 
cg@1470: !SnapShotImage methodsFor:'accessing'!
cg@1470: 
cg@1470: memory
cg@1470:     ^ memory
cg@1470: ! !
cg@1470: 
cg@1415: !SnapShotImage methodsFor:'private'!
cg@1415: 
cg@1415: fetchGlobals
cg@1417:     globals := IdentityDictionary new.
cg@1415:     memory globalEntries do:[:eachEntry |
cg@1417:         |nameSymRef valRef nameSym value|
cg@1415: 
cg@1417:         nameSymRef := eachEntry key.
cg@1417:         valRef := eachEntry value.
cg@1417:         nameSymRef isImageSymbol ifFalse:[self halt].
cg@1415: 
cg@1417:         nameSym := (memory printStringOfSymbol:nameSymRef) asSymbol.
cg@1417:         globals at:nameSym put:valRef
cg@1415:     ].
cg@1415: !
cg@1415: 
cg@1415: for:aFilename
cg@1415:     memory := SnapShotImageMemory for:aFilename.
cg@1418:     memory image:self.
cg@1448:     memory readHeader
cg@1448: ! !
cg@1415: 
cg@1415: !SnapShotImage methodsFor:'smalltalk protocol'!
cg@1415: 
cg@1415: allClassesDo:aBlock
cg@1482:     cachedBehaviors isNil ifTrue:[
cg@1482:         cachedBehaviors := OrderedCollection new.
cg@1482: 
cg@1482:         self keysAndValuesDo:[:key :valRef |
cg@1482:             valRef isInteger ifFalse:[
cg@1482:                 valRef ~~ true ifTrue:[
cg@1482:                     valRef ~~ false ifTrue:[
cg@1482:                         valRef notNil ifTrue:[
cg@1482:                             valRef isImageBehavior ifTrue:[
cg@1482:                                 cachedBehaviors add:valRef
cg@1482:                             ]
cg@1417:                         ]
cg@1417:                     ]
cg@1417:                 ]
cg@1417:             ]
cg@1482:         ].
cg@1415:     ].
cg@1482:     cachedBehaviors do:aBlock
cg@1415: !
cg@1415: 
cg@1418: allClassesInCategory:aCategory
cg@1418:     |coll|
cg@1418: 
cg@1418:     coll := OrderedCollection new.
cg@1418:     self allClassesInCategory:aCategory do:[:aClass |
cg@1418:         coll add:aClass
cg@1418:     ].
cg@1448:     ^ coll
cg@1448: !
cg@1418: 
cg@1418: allClassesInCategory:aCategory do:aBlock
cg@1418:     "evaluate the argument, aBlock for all classes in the aCategory;
cg@1418:      The order of the classes is not defined."
cg@1418: 
cg@1418:     aCategory notNil ifTrue:[
cg@1418:         self allClassesDo:[:aClass |
cg@1418:             aClass isMeta ifFalse:[
cg@1418:                 (aClass category = aCategory) ifTrue:[
cg@1418:                     aBlock value:aClass
cg@1418:                 ]
cg@1418:             ]
cg@1418:         ]
cg@1448:     ]
cg@1448: !
cg@1418: 
cg@1417: at:aKey
cg@1417:     globals isNil ifTrue:[
cg@1417:         self fetchGlobals
cg@1417:     ].
cg@1476:     ^ globals at:aKey ifAbsent:nil
cg@1417: !
cg@1417: 
cg@1418: at:aKey ifAbsent:exceptionValue
cg@1418:     globals isNil ifTrue:[
cg@1418:         self fetchGlobals
cg@1418:     ].
cg@1448:     ^ globals at:aKey ifAbsent:exceptionValue
cg@1448: !
cg@1418: 
cg@1560: classNamed:aString
cg@1560:     "return the class with name aString, or nil if absent.
cg@1560:      To get to the metaClass, append ' class' to the string."
cg@1560: 
cg@1560:     |cls sym meta|
cg@1560: 
cg@1560:     "be careful, to not invent new symbols ..."
cg@1560:     sym := aString asSymbol.
cg@1560:     cls := self at:sym ifAbsent:[].
cg@1560:     cls isBehavior ifTrue:[^ cls].
cg@1560: 
cg@1560:     (aString endsWith:' class') ifTrue:[
cg@1560: 
cg@1560:         meta := self classNamed:(aString copyWithoutLast:6).
cg@1560:         meta notNil ifTrue:[
cg@1560:             ^ meta class
cg@1560:         ].
cg@1560:     ].
cg@1560:     ^ nil
cg@1560: !
cg@1560: 
cg@2131: hasNameSpaces
cg@2131:     ^ true
cg@2131: 
cg@2131:     "Created: / 19-10-2006 / 01:06:31 / cg"
cg@2131: !
cg@2131: 
cg@1584: hasNamespaces
cg@1584:     ^ true
cg@1584: !
cg@1584: 
cg@1415: keysAndValuesDo:aTwoArgBlock
cg@1415:     globals isNil ifTrue:[
cg@1415:         self fetchGlobals
cg@1415:     ].
cg@1415:     globals keysAndValuesDo:aTwoArgBlock
cg@1791: !
cg@1791: 
cg@1791: keysDo:aTwoArgBlock
cg@1791:     globals isNil ifTrue:[
cg@1791:         self fetchGlobals
cg@1791:     ].
cg@1791:     globals keysDo:aTwoArgBlock
cg@1415: ! !
cg@1415: 
cg@1415: !SnapShotImage class methodsFor:'documentation'!
cg@1415: 
cg@1415: version
cg@1415:     ^ '$Header$'
cg@1415: ! !