SnapShotImage.st
author Patrik Svestka <patrik.svestka@gmail.com>
Wed, 14 Nov 2018 12:07:51 +0100
branchjv
changeset 3630 5e718e0a754e
parent 2131 493983865076
permissions -rw-r--r--
Issue #239: Fix all Smalltak/X source files to be in unicode (UTF8 without BOM) and prefixed by "{ Encoding: utf8 }" when any unicode character is present

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