author | Jan Vrany <jan.vrany@fit.cvut.cz> |
Mon, 10 Sep 2012 21:28:05 +0000 | |
changeset 11 | d354ac2af7ec |
parent 10 | fd87600067b8 |
child 14 | f01fe37493e9 |
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:#MetacelloScriptEngine |
|
4 |
instanceVariableNames:'root projectSpec options' |
|
5 |
classVariableNames:'DefaultRepositoryDescription DefaultVersionString' |
|
6 |
poolDictionaries:'' |
|
7 |
category:'Metacello-Core-Scripts' |
|
8 |
! |
|
9 |
||
10 |
||
11 |
!MetacelloScriptEngine class methodsFor:'defaults'! |
|
12 |
||
13 |
defaultRepositoryDescription |
|
14 |
DefaultRepositoryDescription |
|
15 |
ifNil: [ DefaultRepositoryDescription := MetacelloPlatform current defaultRepositoryDescription ]. |
|
16 |
^ DefaultRepositoryDescription |
|
17 |
! |
|
18 |
||
19 |
defaultVersionString |
|
20 |
DefaultVersionString ifNil: [ DefaultVersionString := #'stable' ]. |
|
21 |
^ DefaultVersionString |
|
22 |
! ! |
|
23 |
||
24 |
!MetacelloScriptEngine class methodsFor:'utility'! |
|
25 |
||
26 |
baseNameOf: className |
|
27 |
^ (className indexOfSubCollection: 'BaselineOf') = 0 |
|
28 |
ifTrue: [ |
|
29 |
(className indexOfSubCollection: 'ConfigurationOf') = 0 |
|
30 |
ifTrue: [ className ] |
|
31 |
ifFalse: [ className copyFrom: 'ConfigurationOf' size + 1 to: className size ] ] |
|
32 |
ifFalse: [ className copyFrom: 'BaselineOf' size + 1 to: className size ] |
|
33 |
! |
|
34 |
||
35 |
baselineNameFrom: baseName |
|
36 |
"Return the fully-qualified configuration class name." |
|
37 |
||
38 |
^ (baseName indexOfSubCollection: 'BaselineOf') > 0 |
|
39 |
ifTrue: [ baseName ] |
|
40 |
ifFalse: [ 'BaselineOf' , baseName ] |
|
41 |
! |
|
42 |
||
43 |
baselineProjectNameOf: baselineClassName |
|
44 |
^ (baselineClassName indexOfSubCollection: 'BaselineOf') = 0 |
|
45 |
ifTrue: [ baselineClassName ] |
|
46 |
ifFalse: [ baselineClassName copyFrom: 'BaselineOf' size + 1 to: baselineClassName size ] |
|
47 |
! |
|
48 |
||
49 |
configurationNameFrom: baseName |
|
50 |
"Return the fully-qualified configuration class name." |
|
51 |
||
52 |
^ (baseName indexOfSubCollection: 'ConfigurationOf') > 0 |
|
53 |
ifTrue: [ baseName ] |
|
54 |
ifFalse: [ 'ConfigurationOf' , baseName ] |
|
55 |
! |
|
56 |
||
57 |
configurationProjectNameOf: configurationClassName |
|
58 |
^ (configurationClassName indexOfSubCollection: 'ConfigurationOf') = 0 |
|
59 |
ifTrue: [ configurationClassName ] |
|
60 |
ifFalse: [ configurationClassName copyFrom: 'ConfigurationOf' size + 1 to: configurationClassName size ] |
|
61 |
! ! |
|
62 |
||
63 |
!MetacelloScriptEngine methodsFor:'accessing'! |
|
64 |
||
65 |
options |
|
66 |
options ifNil: [ options := Dictionary new ]. |
|
67 |
^ options |
|
68 |
! |
|
69 |
||
70 |
options: aDictionary |
|
71 |
options := aDictionary |
|
72 |
! |
|
73 |
||
74 |
projectName |
|
75 |
^ self projectSpec name |
|
76 |
! |
|
77 |
||
78 |
projectSpec |
|
79 |
^ projectSpec |
|
80 |
! |
|
81 |
||
82 |
projectSpec: aProjectSpec |
|
83 |
projectSpec := aProjectSpec |
|
84 |
! |
|
85 |
||
86 |
repositories |
|
87 |
^ self projectSpec repositories |
|
88 |
! |
|
89 |
||
90 |
root |
|
91 |
^ root |
|
92 |
! |
|
93 |
||
94 |
root: anObject |
|
95 |
root := anObject |
|
96 |
! ! |
|
97 |
||
98 |
!MetacelloScriptEngine methodsFor:'actions api'! |
|
99 |
||
100 |
fetch: required |
|
101 |
self |
|
102 |
fetchRecord: [ :version | |
|
103 |
required isEmpty |
|
104 |
ifTrue: [ version fetch ] |
|
105 |
ifFalse: [ version fetch: required ] ] |
|
106 |
required: required |
|
107 |
! |
|
108 |
||
109 |
fetchRecord: fetchRecordBlock required: required |
|
110 |
MetacelloProjectRegistration |
|
111 |
copyRegistryWhile: [ |
|
112 |
self |
|
113 |
handleNotificationsForAction: [ |
|
114 |
| version loadedSpec | |
|
115 |
self validateProjectSpecForScript. |
|
116 |
[ loadedSpec := self lookupProjectSpecFor: self projectSpec ] |
|
117 |
on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade |
|
118 |
do: [ :notification | |
|
119 |
notification |
|
120 |
handleOnDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ] |
|
121 |
onUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ] ]. |
|
122 |
version := loadedSpec versionForScriptEngine: self. |
|
123 |
self root: (fetchRecordBlock value: version) loadDirective ] ] |
|
124 |
! |
|
125 |
||
126 |
get |
|
127 |
" load a fresh copy from repo" |
|
128 |
||
129 |
| spec projectPackage | |
|
130 |
MetacelloProjectRegistration |
|
131 |
copyRegistryRestoreOnErrorWhile: [ |
|
132 |
self validateProjectSpecForScript. |
|
133 |
spec := self projectSpec. |
|
134 |
projectPackage := spec projectPackage. |
|
135 |
projectPackage repositorySpecs do: [ :repoSpec | repoSpec createRepository flushForScriptGet ]. |
|
136 |
projectPackage load. |
|
137 |
self root: (Smalltalk at: spec className asSymbol) project. |
|
138 |
MetacelloProjectRegistration |
|
139 |
registrationForProjectSpec: spec |
|
140 |
ifAbsent: [ :new | new registerProject ] |
|
141 |
ifPresent: [ :existing :new | |
|
142 |
existing |
|
143 |
copyOnWrite: [ :existingCopy | |
|
144 |
spec |
|
145 |
copyForRegistration: existingCopy |
|
146 |
onWrite: [ :specCopy | specCopy ifNil: [ existingCopy merge: new ] ifNotNil: [ specCopy mergeScriptRepository: spec ] ] ] ] ] |
|
147 |
! |
|
148 |
||
149 |
list |
|
150 |
self validateProjectSpecForScript. |
|
151 |
self root: self projectSpec |
|
152 |
! |
|
153 |
||
154 |
load: required |
|
155 |
self |
|
156 |
load: required |
|
157 |
onProjectDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ] |
|
158 |
onProjectUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ] |
|
159 |
! |
|
160 |
||
161 |
load: required onProjectDownGrade: onDownGradeBlock onProjectUpgrade: onUpgradeBlock |
|
162 |
MetacelloProjectRegistration |
|
163 |
copyRegistryRestoreOnErrorWhile: [ |
|
164 |
self |
|
165 |
handleNotificationsForAction: [ |
|
166 |
| version loadedSpec | |
|
167 |
self validateProjectSpecForScript. |
|
168 |
[ loadedSpec := self lookupProjectSpecFor: self projectSpec ] |
|
169 |
on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade |
|
170 |
do: [ :ex | ex handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock ]. |
|
171 |
version := loadedSpec versionForScriptEngine: self. |
|
172 |
self |
|
173 |
root: |
|
174 |
(required isEmpty |
|
175 |
ifTrue: [ version load ] |
|
176 |
ifFalse: [ version load: required ]) loadDirective. |
|
177 |
loadedSpec loads: required. |
|
178 |
MetacelloProjectRegistration |
|
179 |
registrationForProjectSpec: loadedSpec |
|
180 |
ifAbsent: [ :new | |
|
181 |
new |
|
182 |
loadedInImage: true; |
|
183 |
registerProject ] |
|
184 |
ifPresent: [ :existing :new | |
|
185 |
existing |
|
186 |
copyOnWrite: [ :existingCopy | |
|
187 |
existingCopy |
|
188 |
loadedInImage: true; |
|
189 |
merge: new ] ] ] ] |
|
190 |
! |
|
191 |
||
192 |
lock |
|
193 |
| spec | |
|
194 |
MetacelloProjectRegistration |
|
195 |
copyRegistryRestoreOnErrorWhile: [ |
|
196 |
self validateProjectSpecForScript. |
|
197 |
spec := self projectSpec. |
|
198 |
MetacelloProjectRegistration |
|
199 |
registrationForProjectSpec: spec |
|
200 |
ifAbsent: [ :new | |
|
201 |
new |
|
202 |
locked: true; |
|
203 |
registerProject ] |
|
204 |
ifPresent: [ :existing :new | |
|
205 |
existing |
|
206 |
copyOnWrite: [ :existingCopy | |
|
207 |
existingCopy locked: true. |
|
208 |
spec |
|
209 |
copyForRegistration: existingCopy |
|
210 |
onWrite: [ :specCopy | |
|
211 |
specCopy |
|
212 |
ifNil: [ existingCopy merge: new ] |
|
213 |
ifNotNil: [ |
|
214 |
specCopy mergeScriptRepository: spec. |
|
215 |
spec := specCopy ] ] ] ]. |
|
216 |
self root: spec ] |
|
217 |
! |
|
218 |
||
219 |
record: required |
|
220 |
self |
|
221 |
fetchRecord: [ :version | |
|
222 |
required isEmpty |
|
223 |
ifTrue: [ version record ] |
|
224 |
ifFalse: [ version record: required ] ] |
|
225 |
required: required |
|
226 |
! |
|
227 |
||
228 |
unlock |
|
229 |
| spec | |
|
230 |
MetacelloProjectRegistration |
|
231 |
copyRegistryRestoreOnErrorWhile: [ |
|
232 |
self validateProjectSpecForScript. |
|
233 |
spec := self projectSpec. |
|
234 |
MetacelloProjectRegistration |
|
235 |
registrationForProjectSpec: spec |
|
236 |
ifAbsent: [ :ignored | ] |
|
237 |
ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy locked: false ] ]. |
|
238 |
self root: spec ] |
|
239 |
! ! |
|
240 |
||
241 |
!MetacelloScriptEngine methodsFor:'defaults'! |
|
242 |
||
243 |
defaultRepositoryDescription |
|
244 |
^ self class defaultRepositoryDescription |
|
245 |
! |
|
246 |
||
247 |
defaultVersionString |
|
248 |
^ self class defaultVersionString |
|
249 |
! ! |
|
250 |
||
251 |
!MetacelloScriptEngine methodsFor:'handlers'! |
|
252 |
||
253 |
handleConflict: exception |
|
254 |
^ (self options at: #'onConflict' ifAbsent: [ ^ exception pass ]) |
|
255 |
cull: exception |
|
256 |
cull: exception existingProjectRegistration |
|
257 |
cull: exception newProjectRegistration |
|
258 |
! |
|
259 |
||
260 |
handleDowngrade: exception |
|
261 |
^ (self options at: #'onDowngrade' ifAbsent: [ ^ exception pass ]) |
|
262 |
cull: exception |
|
263 |
cull: exception existingProjectRegistration |
|
264 |
cull: exception newProjectRegistration |
|
265 |
! |
|
266 |
||
267 |
handleEnsureProjectLoadedForDevelopment: exception |
|
268 |
"if useCurrentVersion resume with true, else resume with false" |
|
269 |
||
270 |
^ exception resume: self useCurrentVersion |
|
271 |
! |
|
272 |
||
273 |
handleLookupBaselineSpecForEnsureLoad: exception |
|
274 |
"if existing and new don't compare equal, then ensure the new baseline is loaded" |
|
275 |
||
276 |
| existing new | |
|
277 |
new := exception projectSpec. |
|
278 |
existing := self lookupBaselineSpecForEnsure: exception projectSpec. |
|
279 |
^ exception resume: (existing registrationsCompareEqual: new) not |
|
280 |
! |
|
281 |
||
282 |
handleLookupProjectSpec: exception |
|
283 |
^ exception |
|
284 |
resume: |
|
285 |
((self lookupProjectSpecFor: exception projectSpec) ifNil: [ ^ exception resume: exception projectSpec ]) |
|
286 |
! |
|
287 |
||
288 |
handleLookupProjectSpecForLoad: exception |
|
289 |
"if overrideProjectSpec is nil, use currentVersion in image, ignoreImage is false" |
|
290 |
||
291 |
| existing new override | |
|
292 |
existing := exception projectSpec. |
|
293 |
override := self useCurrentVersion |
|
294 |
ifTrue: [ |
|
295 |
"don't do lookup in registry if we expect to use the #currentVersion calculation" |
|
296 |
nil ] |
|
297 |
ifFalse: [ |
|
298 |
new := self lookupProjectSpecFor: exception projectSpec. |
|
299 |
(new compareEqual: existing) |
|
300 |
ifFalse: [ |
|
301 |
"counts as override, only if they differ in some aspect" |
|
302 |
override := new ] ]. |
|
303 |
^ exception |
|
304 |
resume: |
|
305 |
(MetacelloProjectSpecForLoad new |
|
306 |
projectSpec: existing; |
|
307 |
useDetermineVersionForLoad: self useCurrentVersion; |
|
308 |
overrideProjectSpec: override; |
|
309 |
yourself) |
|
310 |
! |
|
311 |
||
312 |
handleNotificationsForAction: actionBlock |
|
313 |
[ |
|
314 |
actionBlock |
|
315 |
on: |
|
316 |
MetacelloLookupProjectSpec , MetacelloLookupProjectSpecForLoad , MetacelloProjectSpecLoadedNotification |
|
317 |
, MetacelloScriptEnsureProjectLoadedForDevelopment , MetacelloLookupBaselineSpecForEnsureLoad |
|
318 |
do: [ :ex | |
|
319 |
"lookup and registration handlers need to be innermost set of handlers ...they may throw option notifications" |
|
320 |
ex handleResolutionFor: self ] ] |
|
321 |
on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade , MetacelloAllowConflictingProjectUpgrade |
|
322 |
do: [ :ex | |
|
323 |
"option handlers need to be outermost set of handlers ... last line of defense before users are involved" |
|
324 |
ex handleResolutionFor: self ] |
|
325 |
! |
|
326 |
||
327 |
handleProjectSpecLoaded: exception |
|
328 |
MetacelloProjectRegistration |
|
329 |
registrationForProjectSpec: exception projectSpec |
|
330 |
ifAbsent: [ :new | |
|
331 |
new |
|
332 |
loadedInImage: true; |
|
333 |
registerProject ] |
|
334 |
ifPresent: [ :existing :new | |
|
335 |
"unconditionally merge new with existing (updates registration)" |
|
336 |
existing |
|
337 |
copyOnWrite: [ :existingCopy | |
|
338 |
existingCopy |
|
339 |
loadedInImage: true; |
|
340 |
merge: new ] ]. |
|
341 |
exception resume |
|
342 |
! |
|
343 |
||
344 |
handleUpgrade: exception |
|
345 |
^ (self options at: #'onUpgrade' ifAbsent: [ ^ exception pass ]) |
|
346 |
cull: exception |
|
347 |
cull: exception existingProjectRegistration |
|
348 |
cull: exception newProjectRegistration |
|
349 |
! ! |
|
350 |
||
351 |
!MetacelloScriptEngine methodsFor:'options'! |
|
352 |
||
353 |
cacheRepository |
|
354 |
^ (MetacelloMCProject new repositorySpec description: (self options at: #'cacheRepository' ifAbsent: [ ^ nil ])) |
|
355 |
createRepository |
|
356 |
! |
|
357 |
||
358 |
ignoreImage |
|
359 |
^ self options at: #'ignoreImage' ifAbsent: [ false ] |
|
360 |
! |
|
361 |
||
362 |
repositoryOverrides |
|
363 |
^ (self options at: #'repositoryOverrides' ifAbsent: [ ^ nil ]) |
|
364 |
collect: [ :description | (MetacelloMCProject new repositorySpec description: description) createRepository ] |
|
365 |
! |
|
366 |
||
367 |
silently |
|
368 |
^ self options at: #'silently' ifAbsent: [ false ] |
|
369 |
! |
|
370 |
||
371 |
useCurrentVersion |
|
372 |
"private option used to implement the classic mode" |
|
373 |
||
374 |
^ self options at: #'useCurrentVersion' ifAbsent: [ false ] |
|
375 |
! ! |
|
376 |
||
377 |
!MetacelloScriptEngine methodsFor:'project lookup'! |
|
378 |
||
379 |
getBaselineProjectUnconditionalLoad: unconditionalLoad |
|
380 |
| project | |
|
381 |
project := (self getBaselineUnconditionalLoad: unconditionalLoad) project. |
|
382 |
project version spec repositories: self repositories copy. |
|
383 |
^ project |
|
384 |
! |
|
385 |
||
386 |
getBaselineUnconditionalLoad: unconditionalLoad |
|
387 |
| spec | |
|
388 |
spec := self projectSpec. |
|
389 |
Smalltalk |
|
390 |
at: spec className asSymbol |
|
391 |
ifPresent: [ :cl | |
|
392 |
unconditionalLoad |
|
393 |
ifFalse: [ ^ cl ] ]. |
|
394 |
(spec := self lookupProjectSpecFor: spec) projectPackage load. |
|
395 |
^ Smalltalk at: spec className asSymbol |
|
396 |
! |
|
397 |
||
398 |
getConfigurationProjectUnconditionalLoad: unconditionalLoad |
|
399 |
^ (self getConfigurationUnconditionalLoad: unconditionalLoad) project |
|
400 |
! |
|
401 |
||
402 |
getConfigurationUnconditionalLoad: unconditionalLoad |
|
403 |
| spec | |
|
404 |
spec := self projectSpec. |
|
405 |
Smalltalk |
|
406 |
at: spec className asSymbol |
|
407 |
ifPresent: [ :cl | |
|
408 |
unconditionalLoad |
|
409 |
ifFalse: [ ^ cl ] ]. |
|
410 |
(spec := self lookupProjectSpecFor: spec) projectPackage load. |
|
411 |
^ Smalltalk at: spec className asSymbol |
|
412 |
! |
|
413 |
||
414 |
lookupBaselineSpecForEnsure: aProjectSpec |
|
415 |
| registration loadedSpec | |
|
416 |
registration := MetacelloProjectRegistration |
|
417 |
registrationForProjectSpec: aProjectSpec |
|
418 |
ifAbsent: [ :new | new ] |
|
419 |
ifPresent: [ :existing :new | existing ]. |
|
420 |
^ registration lookupSpec: aProjectSpec |
|
421 |
! |
|
422 |
||
423 |
lookupProjectSpecFor: aProjectSpec |
|
424 |
| registration loadedSpec | |
|
425 |
registration := MetacelloProjectRegistration |
|
426 |
registrationForProjectSpec: aProjectSpec |
|
427 |
ifAbsent: [ :new | new ] |
|
428 |
ifPresent: [ :existing :new | |
|
429 |
(existing hasLoadConflicts: new) |
|
430 |
ifTrue: [ |
|
431 |
((existing canUpgradeTo: new) |
|
432 |
ifTrue: [ MetacelloAllowProjectUpgrade new ] |
|
433 |
ifFalse: [ |
|
434 |
(existing canDowngradeTo: new) |
|
435 |
ifTrue: [ MetacelloAllowProjectDowngrade new ] |
|
436 |
ifFalse: [ MetacelloAllowConflictingProjectUpgrade new ] ]) |
|
437 |
existingProjectRegistration: existing; |
|
438 |
newProjectRegistration: new; |
|
439 |
signal ] |
|
440 |
ifFalse: [ new ] ]. |
|
441 |
^ registration lookupSpec: aProjectSpec |
|
442 |
! |
|
443 |
||
444 |
validateProjectSpecForScript |
|
445 |
| issues | |
|
446 |
issues := self projectSpec |
|
447 |
validateForScriptLoad: self |
|
448 |
withDefaultVersionString: self defaultVersionString |
|
449 |
withDefaultRepositoryDecription: self defaultRepositoryDescription. |
|
450 |
issues isEmpty |
|
451 |
ifTrue: [ ^ self ]. |
|
452 |
(MetacelloValidationFailure issues: issues message: 'Project spec validation failure') signal |
|
453 |
! ! |
|
454 |
||
455 |
!MetacelloScriptEngine class methodsFor:'documentation'! |
|
456 |
||
457 |
version_SVN |
|
458 |
^ '$Id:: $' |
|
459 |
! ! |