1"======================================================================
2|
3|   Magritte compatibility methods for GNU Smalltalk
4|
5|
6 ======================================================================"
7
8"======================================================================
9|
10| Copyright 2008 Free Software Foundation, Inc.
11| Written by Paolo Bonzini.
12|
13| This file is part of the GNU Smalltalk class library.
14|
15| The GNU Smalltalk class library is free software; you can redistribute it
16| and/or modify it under the terms of the GNU Lesser General Public License
17| as published by the Free Software Foundation; either version 2.1, or (at
18| your option) any later version.
19|
20| The GNU Smalltalk class library is distributed in the hope that it will be
21| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
22| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
23| General Public License for more details.
24|
25| You should have received a copy of the GNU Lesser General Public License
26| along with the GNU Smalltalk class library; see the file COPYING.LIB.
27| If not, write to the Free Software Foundation, 59 Temple Place - Suite
28| 330, Boston, MA 02110-1301, USA.
29|
30 ======================================================================"
31
32
33
34Object subclass: MACompatibility [
35
36    <category: 'Magritte-Model-Core'>
37    <comment: 'I am providing all the platform compatibility code on my class side, so that porting to different Smalltalk dialects can concentrate in a single place.'>
38
39    ShowLicense := false.
40
41    MACompatibility class >> allSubInstancesOf: aClass do: aBlock [
42	"Evaluate the aBlock for all instances of aClass and all its subclasses."
43
44	<category: 'environment'>
45	aClass allSubinstancesDo: aBlock
46    ]
47
48    MACompatibility class >> classNamed: aString [
49	"Return the class named aString, nil if the class can't be found."
50
51	<category: 'environment'>
52	^(aString subStrings: $.) inject: Smalltalk into: [ :old :each |
53	    old at: each asSymbol ifAbsent: [ ^nil ] ]
54    ]
55
56    MACompatibility class >> openWorkspace: aContentsString titled: aTitleString [
57	"Open a new wokspace with the contents aContentsString and the title aTitleString."
58
59	ShowLicense ifFalse: [ ^self ].
60	('%1
61
62%2
63' % { aTitleString asUppercase. aContentsString }) displayOn: stderr
64    ]
65
66    MACompatibility class >> referenceStream: aReadWriteStream [
67	"Return a stream instance to operate on aReadWriteStream being able to serialize and deserialize objects by sending #nextPut: and #next. Squeak: The implementation of ReferenceStream doesn't work well together with the default WriteStream implementaiton, therefor we have to change it on the fly."
68
69	<category: 'environment'>
70	^ObjectDumper on: aReadWriteStream
71    ]
72
73    MACompatibility class >> uuid [
74	"Answer a random object that is extremly likely to be unique over space and time."
75
76	<category: 'environment'>
77	^UUID new
78    ]
79]
80
81
82
83ByteArray subclass: UUID [
84
85    <shape: #byte>
86    <category: 'Seaside-Core-Utilities'>
87    <comment: 'I am a UUID.  Sending #new generates a UUIDv1.'>
88
89    Node := nil.
90    SequenceValue := nil.
91    LastTime := nil.
92    Generator := nil.
93    GeneratorMutex := nil.
94
95    UUID class >> timeValue [
96	"Returns the time value for a UUIDv1, in 100 nanoseconds units
97	 since 1-1-1601."
98	^((Time utcSecondClock + (109572 * 86400)) * 1000
99	    + Time millisecondClock) * 10000
100    ]
101
102    UUID class >> randomNodeValue [
103	"Return the node value for a UUIDv1."
104	| n |
105	"TODO: use some kind of digest to produce cryptographically strong
106	 random numbers."
107	n := Generator between: 0 and: 16rFFFF.
108	n := (n bitShift: 16) bitOr: (Generator between: 0 and: 16rFFFF).
109	n := (n bitShift: 16) bitOr: (Generator between: 0 and: 16rFFFF).
110	^n bitOr: 1
111    ]
112
113    UUID class >> update: aSymbol [
114	"Update the sequence value of a UUIDv1 when an image is restarted."
115
116	aSymbol == #returnFromSnapshot ifTrue: [
117	    "You cannot be sure that the node ID is the same."
118	    GeneratorMutex critical: [
119		Generator := Random new.
120		LastTime := self timeValue.
121		Node := self randomNodeValue.
122		SequenceValue := (SequenceValue + 1) bitAnd: 16383 ]].
123    ]
124
125    UUID class >> defaultSize [
126	"Return the size of a UUIDv1."
127
128	<category: 'private'>
129	^16
130    ]
131
132    UUID class >> initialize [
133	"Initialize the class."
134
135	<category: 'initialization'>
136	ObjectMemory addDependent: self.
137	Generator := Random new.
138	LastTime := self timeValue.
139	Node := self randomNodeValue.
140	SequenceValue := Generator between: 0 and: 16383.
141	GeneratorMutex := Semaphore forMutualExclusion.
142    ]
143
144    UUID class >> new [
145	"Return a new UUIDv1."
146
147	<category: 'instance-creation'>
148	^(self new: self defaultSize) initialize
149    ]
150
151    initialize [
152	"Fill in the fields of a new UUIDv1."
153
154	<category: 'private'>
155	| t |
156	GeneratorMutex critical: [
157	    t := self class timeValue bitAnd: 16rFFFFFFFFFFFFFFF.
158	    t <= LastTime
159		ifTrue: [ SequenceValue := (SequenceValue + 1) bitAnd: 16383 ].
160
161	    LastTime := t.
162	    self at: 1 put: ((t bitShift: -24) bitAnd: 255).
163	    self at: 2 put: ((t bitShift: -16) bitAnd: 255).
164	    self at: 3 put: ((t bitShift: -8) bitAnd: 255).
165	    self at: 4 put: (t bitAnd: 255).
166	    self at: 5 put: ((t bitShift: -40) bitAnd: 255).
167	    self at: 6 put: ((t bitShift: -32) bitAnd: 255).
168	    self at: 7 put: (t bitShift: -56) + 16r10.
169	    self at: 8 put: ((t bitShift: -48) bitAnd: 255).
170	    self at: 9 put: (SequenceValue bitShift: -8) + 16r80.
171	    self at: 10 put: (SequenceValue bitAnd: 255).
172	    self at: 13 put: ((Node bitShift: -40) bitAnd: 255).
173	    self at: 14 put: ((Node bitShift: -32) bitAnd: 255).
174	    self at: 15 put: ((Node bitShift: -24) bitAnd: 255).
175	    self at: 16 put: ((Node bitShift: -16) bitAnd: 255).
176	    self at: 11 put: ((Node bitShift: -8) bitAnd: 255).
177	    self at: 12 put: (Node bitAnd: 255)]
178    ]
179
180    printOn: aStream from: a to: b [
181	<category: 'private'>
182	self from: a to: b do: [:each |
183	    aStream nextPut: (Character digitValue: (each bitShift: -4)).
184	    aStream nextPut: (Character digitValue: (each bitAnd: 15)) ]
185    ]
186
187    printOn: aStream [
188	"Print the bytes in the receiver in UUID format."
189	<category: 'printing'>
190	self printOn: aStream from: 1 to: 4.
191	aStream nextPut: $-.
192	self printOn: aStream from: 5 to: 6.
193	aStream nextPut: $-.
194	self printOn: aStream from: 7 to: 8.
195	aStream nextPut: $-.
196	self printOn: aStream from: 9 to: 10.
197	aStream nextPut: $-.
198	self printOn: aStream from: 11 to: 16.
199    ]
200]
201
202
203
204Symbol extend [
205    isUnary [
206	"Return true if the symbol represents a Unary selector."
207	<category: 'testing'>
208
209	^self numArgs = 0
210    ]
211]
212
213FileDescriptor extend [
214    binary [
215	"Do nothing, needed for Squeak compatibility."
216
217	<category: 'squeak compatibility'>
218    ]
219]
220
221Object extend [
222    asString [
223	"Return the #displayString, needed for Squeak compatibility."
224
225	<category: 'squeak compatibility'>
226        ^self displayString
227    ]
228
229    isCollection [
230	"Return false, needed for Squeak compatibility."
231
232	<category: 'squeak compatibility'>
233        ^false
234    ]
235
236    isEmptyOrNil [
237	"Return false, needed for Squeak compatibility."
238
239	<category: 'squeak compatibility'>
240        ^false
241    ]
242
243    isVariableBinding [
244	"Return false, needed by Magritte-Seaside."
245
246	<category: 'squeak compatibility'>
247        ^false
248    ]
249
250]
251
252Association extend [
253    isVariableBinding [
254	"Return false, needed by Magritte-Seaside."
255
256	<category: 'squeak compatibility'>
257        ^true
258    ]
259]
260
261Collection extend [
262    intersection: b [
263	"Return the set of elements common to the receiver and B."
264
265	<category: 'squeak compatibility'>
266        ^self asSet & b
267    ]
268
269    hasEqualElements: b [
270	"Compare the elements in the receiver and B.  Can be improved,
271	 looking at Squeak's implementation."
272
273	<category: 'squeak compatibility'>
274        ^self asArray = b asArray
275    ]
276
277    isCollection [
278	"Return true, needed for Squeak compatibility."
279
280	<category: 'squeak compatibility'>
281        ^true
282    ]
283
284    isEmptyOrNil [
285	"Return true if the collection is empty, needed for Squeak
286	 compatibility."
287
288	<category: 'squeak compatibility'>
289        ^self isEmpty
290    ]
291]
292
293SequenceableCollection extend [
294    sort: aBlock [
295	"Sort the items of the receiver according to the sort block,
296	 aBlock."
297
298	<category: 'squeak compatibility'>
299	self
300	    replaceFrom: 1
301	    to: self size
302	    with: (self asSortedCollection: aBlock)
303	    startingAt: 1
304    ]
305]
306
307SortedCollection extend [
308    sort: aBlock [
309	"Sort the items of the receiver according to the sort block,
310	 aBlock, and change the sort block to aBlock."
311
312	<category: 'squeak compatibility'>
313	sortBlock := aBlock.
314	self sortFrom: firstIndex to: lastIndex.
315        sorted := true.
316        lastOrdered := lastIndex
317    ]
318]
319
320UndefinedObject extend [
321    isEmptyOrNil [
322	"Return true, needed for Squeak compatibility."
323
324	<category: 'squeak compatibility'>
325	^true
326    ]
327]
328
329String extend [
330    includesSubstring: aString caseSensitive: aBoolean [
331	"Needed for Squeak compatibility."
332
333	<category: 'squeak compatibility'>
334	aBoolean ifTrue: [ ^(self indexOfSubCollection: aString) > 0 ].
335	^(self asLowercase indexOfSubCollection: aString asLowercase) > 0
336    ]
337]
338
339ValueHolder extend [
340    contents [
341	"Needed for Squeak compatibility."
342	^self value
343    ]
344    contents: anObject [
345	"Needed for Squeak compatibility."
346	self value: anObject
347    ]
348]
349
350Time extend [
351    print24: boolean24 showSeconds: booleanSec on: aStream [
352        "Print a representation of the receiver on aStream according
353	 to the given flags.  Needed for Squeak compatibility."
354
355        <category: 'arithmetic'>
356	| h |
357	h := boolean24 ifTrue: [ self hour24 ] ifFalse: [ self hour12 ].
358        h printOn: aStream.
359        aStream nextPut: $:.
360        self minutes < 10 ifTrue: [aStream nextPut: $0].
361        self minutes printOn: aStream.
362	booleanSec ifFalse: [ ^self ].
363        aStream nextPut: $:.
364        self seconds < 10 ifTrue: [aStream nextPut: $0].
365        self seconds printOn: aStream
366    ]
367]
368
369Object subclass: MAVisitor [
370    MAVisitor class >> new [
371	<category: 'instance creation'>
372	^super new initialize
373    ]
374    initialize [
375	<category: 'initialization'>
376    ]
377]
378
379
380
381Eval [
382    UUID initialize.
383]
384