author | Jan Vrany <jan.vrany@fit.cvut.cz> |
Tue, 18 Sep 2012 18:24:44 +0000 | |
changeset 16 | 25ac697dc747 |
parent 14 | f01fe37493e9 |
child 22 | e1678fee6b03 |
permissions | -rw-r--r-- |
11
d354ac2af7ec
Metacello package refactoring - phase 2~
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
10
diff
changeset
|
1 |
"{ Package: 'stx:goodies/metacello/core' }" |
1 | 2 |
|
3 |
Object subclass:#MetacelloPlatform |
|
4 |
instanceVariableNames:'bypassProgressBars bypassGoferLoadUpdateCategories' |
|
5 |
classVariableNames:'Current' |
|
6 |
poolDictionaries:'' |
|
7 |
category:'Metacello-Core-Model' |
|
8 |
! |
|
9 |
||
10 |
||
11 |
!MetacelloPlatform class methodsFor:'accessing'! |
|
12 |
||
13 |
current |
|
14 |
Current |
|
15 |
ifNil: [Current := MetacelloPlatform new]. |
|
16 |
^ Current |
|
17 |
! ! |
|
18 |
||
19 |
!MetacelloPlatform class methodsFor:'initialize-release'! |
|
20 |
||
21 |
initialize |
|
22 |
"MetacelloPlatform initialize" |
|
23 |
"MetacelloGemStonePlatform initialize" |
|
24 |
"MetacelloPharoPlatform initialize" |
|
25 |
"MetacelloSqueakPlatform initialize" |
|
26 |
||
27 |
Current := self new |
|
28 |
! ! |
|
29 |
||
30 |
!MetacelloPlatform methodsFor:'accessing'! |
|
31 |
||
32 |
bypassGoferLoadUpdateCategories |
|
33 |
||
34 |
bypassGoferLoadUpdateCategories == nil ifTrue: [ bypassGoferLoadUpdateCategories := false ]. |
|
35 |
^ bypassGoferLoadUpdateCategories |
|
36 |
! |
|
37 |
||
38 |
bypassGoferLoadUpdateCategories: anObject |
|
39 |
bypassGoferLoadUpdateCategories := anObject |
|
40 |
! |
|
41 |
||
42 |
bypassProgressBars |
|
43 |
||
44 |
bypassProgressBars == nil ifTrue: [ bypassProgressBars := false ]. |
|
45 |
^ bypassProgressBars |
|
46 |
! |
|
47 |
||
48 |
bypassProgressBars: anObject |
|
49 |
bypassProgressBars := anObject |
|
50 |
! ! |
|
51 |
||
52 |
!MetacelloPlatform methodsFor:'attributes'! |
|
53 |
||
54 |
defaultPlatformAttributes |
|
55 |
| versionString | |
|
56 |
Smalltalk at: #SystemVersion ifPresent: [:cl | |
|
57 |
versionString := cl current version. |
|
58 |
(versionString beginsWith: 'Pharo') |
|
59 |
ifTrue: [ ^ #(#squeakCommon #pharo ) ]. |
|
60 |
(versionString beginsWith: 'Squeak') |
|
61 |
ifTrue: [^ #(#squeakCommon #squeak )]. |
|
62 |
"see http://code.google.com/p/metacello/issues/detail?id=146" |
|
63 |
(versionString includesSubString: 'Pharo') |
|
64 |
ifTrue: [ ^ #(#squeakCommon #pharo ) ]. |
|
65 |
(versionString includesSubString: 'Squeak') |
|
66 |
ifTrue: [^ #(#squeakCommon #squeak )]. |
|
67 |
self error: 'Unrecognized version of Squeak/Pharo: ', versionString ]. |
|
68 |
^ #(#gemstone ) |
|
69 |
! ! |
|
70 |
||
71 |
!MetacelloPlatform methodsFor:'caching'! |
|
72 |
||
73 |
clearCurrentVersionCache |
|
74 |
MetacelloClearStackCacheNotification signal: #(#currentVersion #currentVersionAgainst: #currentVersionInfo) |
|
75 |
! |
|
76 |
||
77 |
primeStackCacheFor: cacheName doing: noArgBlock defaultDictionary: aDictionary |
|
78 |
||
79 |
self deprecated: 'use #primeStackCacheWith:doing:'. |
|
80 |
self |
|
81 |
useStackCacheDuring: [:dict | | cache | |
|
82 |
cache := dict at: cacheName ifAbsent: []. |
|
83 |
cache == nil |
|
84 |
ifTrue: [ |
|
85 |
cache := Dictionary new. |
|
86 |
dict at: cacheName put: cache ]. |
|
87 |
^noArgBlock value ] |
|
88 |
defaultDictionary: aDictionary |
|
89 |
! |
|
90 |
||
91 |
primeStackCacheWith: aDictionary doing: noArgBlock |
|
92 |
||
93 |
self |
|
94 |
useStackCacheDuring: [:dict | ^noArgBlock value ] |
|
95 |
defaultDictionary: aDictionary |
|
96 |
! |
|
97 |
||
98 |
stackCacheFor: cacheName at: key doing: aBlock |
|
99 |
||
100 |
^self stackCacheFor: cacheName cacheClass: Dictionary at: key doing: aBlock |
|
101 |
! |
|
102 |
||
103 |
stackCacheFor: cacheName cacheClass: cacheClass at: key doing: aBlock |
|
104 |
||
105 |
self |
|
106 |
useStackCacheDuring: [:dict | | cache | |
|
107 |
cache := dict at: cacheName ifAbsent: []. |
|
108 |
cache ~~ nil |
|
109 |
ifTrue: [ | value hasEntry | |
|
110 |
hasEntry := true. |
|
111 |
value := cache at: key ifAbsent: [ hasEntry := false ]. |
|
112 |
hasEntry ifTrue: [ ^value ]] |
|
113 |
ifFalse: [ |
|
114 |
cache := cacheClass new. |
|
115 |
dict at: cacheName put: cache ]. |
|
116 |
^aBlock value: cache ] |
|
117 |
defaultDictionary: nil |
|
118 |
! |
|
119 |
||
120 |
useStackCacheDuring: aBlock defaultDictionary: defaultDictionary |
|
121 |
| dict | |
|
122 |
dict := MetacelloStackCacheNotification signal. |
|
123 |
dict == nil |
|
124 |
ifTrue: [ |
|
125 |
dict := defaultDictionary == nil |
|
126 |
ifTrue: [ Dictionary new ] |
|
127 |
ifFalse: [ defaultDictionary ] ]. |
|
128 |
[ ^ aBlock value: dict ] |
|
129 |
on: MetacelloStackCacheNotification , MetacelloClearStackCacheNotification |
|
130 |
do: [ :ex | |
|
131 |
(ex isKindOf: MetacelloStackCacheNotification) |
|
132 |
ifTrue: [ ex resume: dict ]. |
|
133 |
(ex isKindOf: MetacelloClearStackCacheNotification) |
|
134 |
ifTrue: [ |
|
135 |
| keys | |
|
136 |
keys := ex cacheNames. |
|
137 |
keys ifNil: [ keys := dict keys ]. |
|
138 |
keys |
|
139 |
do: [ :k | |
|
140 |
(dict includesKey: k) |
|
141 |
ifTrue: [ |
|
142 |
| c | |
|
143 |
c := dict at: k. |
|
144 |
c keys do: [ :ck | c removeKey: ck ]. |
|
145 |
dict removeKey: k ] ]. |
|
146 |
ex resume ] ] |
|
147 |
! ! |
|
148 |
||
16
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
149 |
!MetacelloPlatform methodsFor:'github support'! |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
150 |
|
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
151 |
downloadFile: url to: outputFileName |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
152 |
"download from <url> into <outputFileName>" |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
153 |
|
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
154 |
self subclassResponsibility |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
155 |
! |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
156 |
|
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
157 |
extractRepositoryFrom: zipFile to: directory |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
158 |
"unzip <zipFile> into <directory>" |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
159 |
|
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
160 |
self subclassResponsibility |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
161 |
! |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
162 |
|
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
163 |
fileDirectoryClass |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
164 |
|
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
165 |
^FileDirectory |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
166 |
! ! |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
167 |
|
1 | 168 |
!MetacelloPlatform methodsFor:'notification'! |
169 |
||
170 |
collection: aCollection do: aBlock displaying: aString |
|
171 |
||
172 |
aCollection do: aBlock |
|
173 |
! |
|
174 |
||
175 |
do: aBlock displaying: aString |
|
176 |
||
177 |
aBlock value |
|
178 |
! ! |
|
179 |
||
180 |
!MetacelloPlatform methodsFor:'reflection'! |
|
181 |
||
182 |
copyClass: oldClass as: newName inCategory: newCategoryName |
|
183 |
||
184 |
self subclassResponsibility |
|
185 |
! |
|
186 |
||
187 |
globalNamed: globalName |
|
188 |
||
189 |
^Smalltalk at: globalName |
|
190 |
! |
|
191 |
||
192 |
globalNamed: globalName ifAbsent: absentBlock |
|
193 |
||
194 |
^Smalltalk at: globalName ifAbsent: absentBlock |
|
195 |
! ! |
|
196 |
||
197 |
!MetacelloPlatform methodsFor:'repository creation'! |
|
198 |
||
199 |
createRepository: aRepositorySpec |
|
16
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
200 |
| type | |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
201 |
type := aRepositorySpec type. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
202 |
type = 'http' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
203 |
ifTrue: [ |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
204 |
^ MCHttpRepository |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
205 |
location: aRepositorySpec description |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
206 |
user: aRepositorySpec username |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
207 |
password: aRepositorySpec password ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
208 |
type = 'directory' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
209 |
ifTrue: [ ^ MCDirectoryRepository new directory: (FileDirectory on: aRepositorySpec description) ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
210 |
Smalltalk |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
211 |
at: #'MCFileTreeRepository' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
212 |
ifPresent: [ :cl | |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
213 |
type = 'filetree' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
214 |
ifTrue: [ |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
215 |
| description headerSize | |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
216 |
description := aRepositorySpec description. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
217 |
headerSize := 'filetree://' size. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
218 |
^ cl new |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
219 |
directory: |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
220 |
(FileDirectory on: (aRepositorySpec description copyFrom: headerSize + 1 to: description size)) ] ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
221 |
Smalltalk |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
222 |
at: #'MCGitHubRepository' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
223 |
ifPresent: [ :cl | |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
224 |
type = 'github' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
225 |
ifTrue: [ ^ cl location: aRepositorySpec description ] ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
226 |
type = 'dictionary' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
227 |
ifTrue: [ |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
228 |
| description headerSize globalName | |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
229 |
description := aRepositorySpec description. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
230 |
headerSize := 'dictionary://' size. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
231 |
globalName := (description copyFrom: headerSize + 1 to: description size) asSymbol. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
232 |
^ Smalltalk |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
233 |
at: globalName |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
234 |
ifAbsent: [ |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
235 |
Smalltalk |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
236 |
at: globalName |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
237 |
put: |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
238 |
(MCDictionaryRepository new |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
239 |
description: description; |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
240 |
yourself) ] ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
241 |
^ nil |
1 | 242 |
! |
243 |
||
244 |
extractTypeFromDescription: description |
|
16
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
245 |
description == nil |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
246 |
ifTrue: [ ^ nil ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
247 |
((description beginsWith: '/') or: [ description second = $: ]) |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
248 |
ifTrue: [ ^ 'directory' ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
249 |
(description beginsWith: 'dictionary://') |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
250 |
ifTrue: [ ^ 'dictionary' ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
251 |
(description beginsWith: 'filetree://') |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
252 |
ifTrue: [ ^ 'filetree' ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
253 |
(description beginsWith: 'github://') |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
254 |
ifTrue: [ ^ 'github' ]. |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
255 |
^ 'http' |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
256 |
! ! |
1 | 257 |
|
16
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
258 |
!MetacelloPlatform methodsFor:'scripting'! |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
259 |
|
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
260 |
defaultRepositoryDescription |
25ac697dc747
- Updated from branch master
Jan Vrany <jan.vrany@fit.cvut.cz>
parents:
14
diff
changeset
|
261 |
^ 'http://www.squeaksource.com/MetacelloRepository' |
1 | 262 |
! ! |
263 |
||
264 |
!MetacelloPlatform methodsFor:'tests'! |
|
265 |
||
266 |
defaultTimeout |
|
267 |
"squeak compatability" |
|
268 |
^60 |
|
269 |
! ! |
|
270 |
||
271 |
!MetacelloPlatform methodsFor:'transactions'! |
|
272 |
||
273 |
transact: aBlock |
|
274 |
"On GemStone, we want to optionally abort before command execution and commit after |
|
275 |
common execution. Other plaforms don't need to do anything special. |
|
276 |
Returning out of block, skips commit." |
|
277 |
||
278 |
aBlock value |
|
279 |
! ! |
|
280 |
||
281 |
!MetacelloPlatform methodsFor:'user interaction'! |
|
282 |
||
283 |
confirm: aString |
|
284 |
||
285 |
^(Smalltalk hasClassNamed: #UIManager) |
|
286 |
ifTrue: [ (Smalltalk classNamed: #UIManager) default perform: #confirm: with: aString ] |
|
287 |
ifFalse: [ |
|
288 |
"throw warning and answer true, if no way to announce" |
|
289 |
Warning signal: aString. |
|
290 |
true ] |
|
291 |
! ! |
|
292 |
||
293 |
!MetacelloPlatform methodsFor:'utilities'! |
|
294 |
||
295 |
authorName |
|
296 |
||
297 |
Smalltalk at: #Author ifPresent: [:cl | ^cl perform: #initials ]. |
|
298 |
^'no developer initials' |
|
299 |
! |
|
300 |
||
301 |
authorName: aString |
|
302 |
"Primarily used for testing" |
|
303 |
||
304 |
self subclassResponsibility |
|
305 |
! |
|
306 |
||
307 |
timestamp |
|
308 |
||
309 |
^DateAndTime now printString |
|
310 |
! ! |
|
311 |
||
312 |
!MetacelloPlatform class methodsFor:'documentation'! |
|
313 |
||
314 |
version_SVN |
|
315 |
^ '$Id:: $' |
|
316 |
! ! |
|
317 |
||
318 |
MetacelloPlatform initialize! |