SnapShotImage.st
author Claus Gittinger <cg@exept.de>
Tue, 14 May 2019 09:46:21 +0200
changeset 3663 9d49ecf8661a
parent 2131 493983865076
permissions -rw-r--r--
#UI_ENHANCEMENT by cg
class: TabListEditor class
changed:
#canvasSpec
#menu
#windowSpec
cg@1448
     1
"{ Package: 'stx:libtool2' }"
cg@1415
     2
cg@1415
     3
Object subclass:#SnapShotImage
cg@1482
     4
	instanceVariableNames:'memory globals cachedBehaviors'
cg@1415
     5
	classVariableNames:''
cg@1415
     6
	poolDictionaries:''
cg@1415
     7
	category:'System-Support'
cg@1415
     8
!
cg@1415
     9
cg@1448
    10
!SnapShotImage class methodsFor:'documentation'!
cg@1448
    11
cg@1448
    12
documentation
cg@1448
    13
"
cg@1448
    14
    I simulate a Smalltalk environment as present in a snapshot image.
cg@1448
    15
    My protocol mimics the NameSpace (i.e. class-environment) protocol,
cg@1448
    16
    and I can be used as a Browsers environment, in order to open a
cg@1448
    17
    browser into an old snapShot image (st.img - file).
cg@1448
    18
cg@1448
    19
    I am not used directly; instead, via the SystemBrowsers entry:
cg@1448
    20
        SystemBrowser openOnSnapShotImage:'/export/home/cg/work/stx/projects/smalltalk/st.img'
cg@1448
    21
cg@1483
    22
        SystemBrowser openOnSnapShotImage:'st.img'
cg@1483
    23
cg@1483
    24
    This enables a standard browser to peek into a snapshot image... (well, almost)
cg@1483
    25
cg@1448
    26
    [author:]
cg@1448
    27
        Claus Gittinger
cg@1448
    28
"
cg@1470
    29
!
cg@1470
    30
cg@1470
    31
examples
cg@1470
    32
"
cg@1470
    33
    |i m|
cg@1470
    34
cg@1470
    35
    i := self for:'st.img'.
cg@1470
    36
    m := i memory.
cg@1470
    37
    m  fetchObjectAt:16r38000000
cg@1470
    38
"
cg@1448
    39
! !
cg@1415
    40
cg@1415
    41
!SnapShotImage class methodsFor:'instance creation'!
cg@1415
    42
cg@1415
    43
for:aFilename
cg@1415
    44
    ^ self new for:aFilename
cg@1415
    45
! !
cg@1415
    46
cg@1470
    47
!SnapShotImage methodsFor:'accessing'!
cg@1470
    48
cg@1470
    49
memory
cg@1470
    50
    ^ memory
cg@1470
    51
! !
cg@1470
    52
cg@1415
    53
!SnapShotImage methodsFor:'private'!
cg@1415
    54
cg@1415
    55
fetchGlobals
cg@1417
    56
    globals := IdentityDictionary new.
cg@1415
    57
    memory globalEntries do:[:eachEntry |
cg@1417
    58
        |nameSymRef valRef nameSym value|
cg@1415
    59
cg@1417
    60
        nameSymRef := eachEntry key.
cg@1417
    61
        valRef := eachEntry value.
cg@1417
    62
        nameSymRef isImageSymbol ifFalse:[self halt].
cg@1415
    63
cg@1417
    64
        nameSym := (memory printStringOfSymbol:nameSymRef) asSymbol.
cg@1417
    65
        globals at:nameSym put:valRef
cg@1415
    66
    ].
cg@1415
    67
!
cg@1415
    68
cg@1415
    69
for:aFilename
cg@1415
    70
    memory := SnapShotImageMemory for:aFilename.
cg@1418
    71
    memory image:self.
cg@1448
    72
    memory readHeader
cg@1448
    73
! !
cg@1415
    74
cg@1415
    75
!SnapShotImage methodsFor:'smalltalk protocol'!
cg@1415
    76
cg@1415
    77
allClassesDo:aBlock
cg@1482
    78
    cachedBehaviors isNil ifTrue:[
cg@1482
    79
        cachedBehaviors := OrderedCollection new.
cg@1482
    80
cg@1482
    81
        self keysAndValuesDo:[:key :valRef |
cg@1482
    82
            valRef isInteger ifFalse:[
cg@1482
    83
                valRef ~~ true ifTrue:[
cg@1482
    84
                    valRef ~~ false ifTrue:[
cg@1482
    85
                        valRef notNil ifTrue:[
cg@1482
    86
                            valRef isImageBehavior ifTrue:[
cg@1482
    87
                                cachedBehaviors add:valRef
cg@1482
    88
                            ]
cg@1417
    89
                        ]
cg@1417
    90
                    ]
cg@1417
    91
                ]
cg@1417
    92
            ]
cg@1482
    93
        ].
cg@1415
    94
    ].
cg@1482
    95
    cachedBehaviors do:aBlock
cg@1415
    96
!
cg@1415
    97
cg@1418
    98
allClassesInCategory:aCategory
cg@1418
    99
    |coll|
cg@1418
   100
cg@1418
   101
    coll := OrderedCollection new.
cg@1418
   102
    self allClassesInCategory:aCategory do:[:aClass |
cg@1418
   103
        coll add:aClass
cg@1418
   104
    ].
cg@1448
   105
    ^ coll
cg@1448
   106
!
cg@1418
   107
cg@1418
   108
allClassesInCategory:aCategory do:aBlock
cg@1418
   109
    "evaluate the argument, aBlock for all classes in the aCategory;
cg@1418
   110
     The order of the classes is not defined."
cg@1418
   111
cg@1418
   112
    aCategory notNil ifTrue:[
cg@1418
   113
        self allClassesDo:[:aClass |
cg@1418
   114
            aClass isMeta ifFalse:[
cg@1418
   115
                (aClass category = aCategory) ifTrue:[
cg@1418
   116
                    aBlock value:aClass
cg@1418
   117
                ]
cg@1418
   118
            ]
cg@1418
   119
        ]
cg@1448
   120
    ]
cg@1448
   121
!
cg@1418
   122
cg@1417
   123
at:aKey
cg@1417
   124
    globals isNil ifTrue:[
cg@1417
   125
        self fetchGlobals
cg@1417
   126
    ].
cg@1476
   127
    ^ globals at:aKey ifAbsent:nil
cg@1417
   128
!
cg@1417
   129
cg@1418
   130
at:aKey ifAbsent:exceptionValue
cg@1418
   131
    globals isNil ifTrue:[
cg@1418
   132
        self fetchGlobals
cg@1418
   133
    ].
cg@1448
   134
    ^ globals at:aKey ifAbsent:exceptionValue
cg@1448
   135
!
cg@1418
   136
cg@1560
   137
classNamed:aString
cg@1560
   138
    "return the class with name aString, or nil if absent.
cg@1560
   139
     To get to the metaClass, append ' class' to the string."
cg@1560
   140
cg@1560
   141
    |cls sym meta|
cg@1560
   142
cg@1560
   143
    "be careful, to not invent new symbols ..."
cg@1560
   144
    sym := aString asSymbol.
cg@1560
   145
    cls := self at:sym ifAbsent:[].
cg@1560
   146
    cls isBehavior ifTrue:[^ cls].
cg@1560
   147
cg@1560
   148
    (aString endsWith:' class') ifTrue:[
cg@1560
   149
cg@1560
   150
        meta := self classNamed:(aString copyWithoutLast:6).
cg@1560
   151
        meta notNil ifTrue:[
cg@1560
   152
            ^ meta class
cg@1560
   153
        ].
cg@1560
   154
    ].
cg@1560
   155
    ^ nil
cg@1560
   156
!
cg@1560
   157
cg@2131
   158
hasNameSpaces
cg@2131
   159
    ^ true
cg@2131
   160
cg@2131
   161
    "Created: / 19-10-2006 / 01:06:31 / cg"
cg@2131
   162
!
cg@2131
   163
cg@1584
   164
hasNamespaces
cg@1584
   165
    ^ true
cg@1584
   166
!
cg@1584
   167
cg@1415
   168
keysAndValuesDo:aTwoArgBlock
cg@1415
   169
    globals isNil ifTrue:[
cg@1415
   170
        self fetchGlobals
cg@1415
   171
    ].
cg@1415
   172
    globals keysAndValuesDo:aTwoArgBlock
cg@1791
   173
!
cg@1791
   174
cg@1791
   175
keysDo:aTwoArgBlock
cg@1791
   176
    globals isNil ifTrue:[
cg@1791
   177
        self fetchGlobals
cg@1791
   178
    ].
cg@1791
   179
    globals keysDo:aTwoArgBlock
cg@1415
   180
! !
cg@1415
   181
cg@1415
   182
!SnapShotImage class methodsFor:'documentation'!
cg@1415
   183
cg@1415
   184
version
cg@1415
   185
    ^ '$Header$'
cg@1415
   186
! !