1 "{ Package: 'stx:goodies/monticello' }"! |
1 "{ Package: 'stx:goodies/monticello' }"! |
2 |
2 |
3 !Behavior methodsFor:'* monticello'! |
3 !Annotation class methodsFor:'instance creation'! |
|
4 |
|
5 mctimestamp: aString |
|
6 |
|
7 ^MCTimestampAnnotation new timestamp: aString |
|
8 |
|
9 "Created: / 14-09-2010 / 15:35:07 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
10 ! ! |
|
11 |
|
12 !Behavior methodsFor:'*monticello-squeakCompatibility'! |
|
13 |
|
14 includesLocalSelector:aSymbol |
|
15 ^ self localSelectors includes:aSymbol |
|
16 |
|
17 "Created: / 26-08-2009 / 11:50:00 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
18 ! ! |
|
19 |
|
20 !Behavior methodsFor:'*monticello-squeakCompatibility'! |
|
21 |
|
22 localSelectors |
|
23 ^ self methodDictionary collect:[:x | x selector asSymbol ] |
|
24 |
|
25 "Created: / 26-08-2009 / 11:53:47 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
26 ! ! |
|
27 |
|
28 !Behavior methodsFor:'*monticello-squeakCompatibility'! |
|
29 |
|
30 traitCompositionString |
|
31 ^ '{}' |
|
32 |
|
33 "Created: / 26-08-2009 / 12:43:23 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
34 ! ! |
|
35 |
|
36 !Behavior methodsFor:'*monticello-squeakCompatibility'! |
4 |
37 |
5 typeOfClass |
38 typeOfClass |
6 "Answer a symbol uniquely describing the type of the receiver" |
39 "Answer a symbol uniquely describing the type of the receiver" |
7 |
40 "self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]." "Very special!!" |
8 "/ self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" |
41 self isBytes ifTrue:[^#bytes]. |
9 (self isSubclassOf:#CompiledCode) ifTrue:[^#compiledMethod]. "Very special!!" |
42 (self isWords and:[self isPointers not]) ifTrue:[^#words]. |
10 self isBytes ifTrue:[^#bytes]. |
43 self isWeakPointers ifTrue:[^#weak]. |
11 (self isWords and:[self isPointers not]) ifTrue:[^#words]. |
44 self isVariable ifTrue:[^#variable]. |
12 (self isLongs and:[self isPointers not]) ifTrue:[^#longs]. |
45 ^#normal. |
13 self isWeakPointers ifTrue:[^#weak]. |
46 |
14 "/ self isWeak ifTrue:[^#weak]. |
47 "Created: / 26-08-2009 / 12:45:50 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
15 self isVariable ifTrue:[^#variable]. |
48 ! ! |
16 ^#normal. |
49 |
|
50 !Boolean methodsFor:'*monticello-squeakCompatibility'! |
|
51 |
|
52 and: block1 and: block2 |
|
53 "Nonevaluating conjunction without deep nesting. |
|
54 The receiver is evaluated, followed by the blocks in order. |
|
55 If any of these evaluates as false, then return false immediately, |
|
56 without evaluating any further blocks. |
|
57 If all return true, then return true." |
|
58 |
|
59 self ifFalse: [^ false]. |
|
60 block1 value ifFalse: [^ false]. |
|
61 block2 value ifFalse: [^ false]. |
|
62 ^ true |
|
63 |
|
64 "Created: / 26-08-2009 / 11:47:54 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
65 ! ! |
|
66 |
|
67 !Boolean methodsFor:'*monticello-squeakCompatibility'! |
|
68 |
|
69 or: block1 or: block2 or: block3 or: block4 |
|
70 "Nonevaluating alternation without deep nesting. |
|
71 The receiver is evaluated, followed by the blocks in order. |
|
72 If any of these evaluates as true, then return true immediately, |
|
73 without evaluating any further blocks. |
|
74 If all return false, then return false." |
|
75 |
|
76 self ifTrue: [^ true]. |
|
77 block1 value ifTrue: [^ true]. |
|
78 block2 value ifTrue: [^ true]. |
|
79 block3 value ifTrue: [^ true]. |
|
80 block4 value ifTrue: [^ true]. |
|
81 ^ false |
|
82 |
|
83 "Created: / 26-08-2009 / 12:21:41 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
84 ! ! |
|
85 |
|
86 !Change methodsFor:'accessing'! |
|
87 |
|
88 mcDefinition |
|
89 |
|
90 ^self objectAttributeAt: #mcDefinition |
|
91 |
|
92 "Created: / 08-11-2010 / 17:56:01 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
93 ! ! |
|
94 |
|
95 !Change methodsFor:'accessing'! |
|
96 |
|
97 mcDefinition: aMCDefinition |
|
98 |
|
99 ^self objectAttributeAt: #mcDefinition put: aMCDefinition |
|
100 |
|
101 "Created: / 08-11-2010 / 17:56:12 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
17 ! ! |
102 ! ! |
18 |
103 |
19 !Class methodsFor:'*monticello'! |
104 !Class methodsFor:'*monticello'! |
20 |
105 |
21 asClassDefinition |
106 asClassDefinition |
22 self isLoaded ifFalse:[ |
107 ^ MCClassDefinition |
23 ^ self autoload asClassDefinition |
108 name: self name |
24 ]. |
109 superclassName: self superclass name |
25 ^ MCClassDefinition |
110 traitComposition: self traitCompositionString |
26 name: self name |
111 classTraitComposition: self class traitCompositionString |
27 superclassName: self superclass name |
112 category: self category |
28 category: self category |
113 instVarNames: self instVarNames |
29 instVarNames: self instVarNames |
114 classVarNames: self classVarNames |
30 classVarNames: self classVarNames |
115 poolDictionaryNames: self poolDictionaryNames |
31 poolDictionaryNames: self poolDictionaryNames |
116 classInstVarNames: self class instVarNames |
32 classInstVarNames: self class instVarNames |
117 type: self typeOfClass |
33 type: self typeOfClass |
118 comment: (self organization classComment ? '') asStringWithSqueakLineEndings |
34 comment: (Smalltalk isSmalltalkX ifTrue:[self comment] ifFalse:[ self organization classComment asString ]) |
119 commentStamp: self organization commentStamp |
35 commentStamp: (Smalltalk isSmalltalkX ifTrue:[nil] ifFalse:[self organization commentStamp]) |
120 |
|
121 "Modified: / 12-09-2010 / 17:19:14 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
36 ! ! |
122 ! ! |
37 |
123 |
38 !Class methodsFor:'*monticello'! |
124 !Class methodsFor:'*monticello'! |
39 |
125 |
40 classDefinitions |
126 classDefinitions |
79 comment:'' |
165 comment:'' |
80 changed:false |
166 changed:false |
81 classInstanceVariableNames:''. |
167 classInstanceVariableNames:''. |
82 ! ! |
168 ! ! |
83 |
169 |
|
170 !ClassDescription methodsFor:'*monticello-squeakCompatibility'! |
|
171 |
|
172 classSide |
|
173 |
|
174 ^ self theMetaclass |
|
175 |
|
176 "Created: / 26-08-2009 / 11:44:51 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
177 "Modified: / 12-09-2010 / 16:38:29 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
178 ! ! |
|
179 |
|
180 !ClassDescription methodsFor:'*monticello-squeakCompatibility'! |
|
181 |
|
182 mcDefinition |
|
183 |
|
184 |s| |
|
185 |
|
186 s := WriteStream on:(String new). |
|
187 self |
|
188 basicFileOutDefinitionOn:s |
|
189 withNameSpace:false |
|
190 withPackage:false. |
|
191 s position: s position - 1. |
|
192 |
|
193 ^ s contents |
|
194 |
|
195 "Created: / 11-09-2010 / 18:06:19 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
196 ! ! |
|
197 |
|
198 !ClassDescription methodsFor:'*monticello-squeakCompatibility'! |
|
199 |
|
200 theNonMetaClass |
|
201 ^ self |
|
202 |
|
203 "Created: / 26-08-2009 / 11:39:08 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
204 ! ! |
|
205 |
|
206 !Metaclass methodsFor:'*monticello-squeakCompatibility'! |
|
207 |
|
208 theNonMetaClass |
|
209 ^ myClass |
|
210 |
|
211 "Created: / 26-08-2009 / 11:39:48 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
212 ! ! |
|
213 |
84 !Object methodsFor:'*monticello'! |
214 !Object methodsFor:'*monticello'! |
85 |
215 |
86 isConflict |
216 isConflict |
87 ^false |
217 ^false |
88 ! ! |
218 ! ! |
89 |
219 |
|
220 !PackageInfo methodsFor:'comparing'! |
|
221 |
|
222 = other |
|
223 ^ other species = self species and: [other packageName = self packageName] |
|
224 ! ! |
|
225 |
|
226 !PackageInfo methodsFor:'modifying'! |
|
227 |
|
228 addCoreMethod: aMethodReference |
|
229 | category | |
|
230 category := self baseCategoryOfMethod: aMethodReference. |
|
231 aMethodReference actualClass organization |
|
232 classify: aMethodReference methodSymbol |
|
233 under: category |
|
234 suppressIfDefault: false |
|
235 ! ! |
|
236 |
|
237 !PackageInfo methodsFor:'modifying'! |
|
238 |
|
239 addExtensionMethod: aMethodReference |
|
240 | category | |
|
241 category := self baseCategoryOfMethod: aMethodReference. |
|
242 aMethodReference actualClass organization |
|
243 classify: aMethodReference methodSymbol |
|
244 under: self methodCategoryPrefix, '-', category |
|
245 ! ! |
|
246 |
|
247 !PackageInfo methodsFor:'modifying'! |
|
248 |
|
249 addMethod: aMethodReference |
|
250 (self includesClass: aMethodReference class) |
|
251 ifTrue: [self addCoreMethod: aMethodReference] |
|
252 ifFalse: [self addExtensionMethod: aMethodReference] |
|
253 ! ! |
|
254 |
|
255 !PackageInfo methodsFor:'modifying'! |
|
256 |
|
257 baseCategoryOfMethod: aMethodReference |
|
258 | oldCat oldPrefix tokens | |
|
259 oldCat := aMethodReference category. |
|
260 ({ 'as yet unclassified'. 'all' } includes: oldCat) ifTrue: [ oldCat := '' ]. |
|
261 tokens := oldCat findTokens: '*-' keep: '*'. |
|
262 |
|
263 "Strip off any old prefixes" |
|
264 ((tokens at: 1 ifAbsent: [ '' ]) = '*') ifTrue: [ |
|
265 [ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ] |
|
266 whileTrue: [ tokens removeFirst ]. |
|
267 oldPrefix := tokens removeFirst asLowercase. |
|
268 [ (tokens at: 1 ifAbsent: [ '' ]) asLowercase = oldPrefix ] |
|
269 whileTrue: [ tokens removeFirst ]. |
|
270 ]. |
|
271 |
|
272 tokens isEmpty ifTrue: [^ 'as yet unclassified']. |
|
273 ^ String streamContents: |
|
274 [ :s | |
|
275 tokens |
|
276 do: [ :tok | s nextPutAll: tok ] |
|
277 separatedBy: [ s nextPut: $- ]] |
|
278 ! ! |
|
279 |
|
280 !PackageInfo methodsFor:'testing'! |
|
281 |
|
282 category: categoryName matches: prefix |
|
283 ^ categoryName notNil and: [categoryName = prefix or: [categoryName beginsWith: prefix, '-']] |
|
284 ! ! |
|
285 |
|
286 !PackageInfo methodsFor:'naming'! |
|
287 |
|
288 categoryName |
|
289 |category| |
|
290 category := self class category. |
|
291 ^ (category endsWith: '-Info') |
|
292 ifTrue: [category copyUpToLast: $-] |
|
293 ifFalse: [category] |
|
294 ! ! |
|
295 |
|
296 !PackageInfo methodsFor:'listing'! |
|
297 |
|
298 classesAndMetaClasses |
|
299 | baseClasses | |
|
300 baseClasses := self classes. |
|
301 ^baseClasses , (baseClasses collect: [:c | c classSide]) |
|
302 ! ! |
|
303 |
|
304 !PackageInfo methodsFor:'testing'! |
|
305 |
|
306 coreCategoriesForClass: aClass |
|
307 ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not] |
|
308 ! ! |
|
309 |
|
310 !PackageInfo methodsFor:'listing'! |
|
311 |
|
312 coreMethods |
|
313 ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class] |
|
314 ! ! |
|
315 |
|
316 !PackageInfo methodsFor:'testing'! |
|
317 |
|
318 coreMethodsForClass:aClass |
|
319 ^ ((aClass selectors difference: (aClass isMetaclass ifTrue:[#(#version_MC)] ifFalse:[#()])) |
|
320 difference:((self foreignExtensionMethodsForClass:aClass) |
|
321 collect:[:r | r methodSymbol ])) |
|
322 asArray collect:[:sel | self referenceForMethod:sel ofClass:aClass ] |
|
323 |
|
324 "Modified: / 14-09-2010 / 15:59:59 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
325 ! ! |
|
326 |
|
327 !PackageInfo methodsFor:'testing'! |
|
328 |
|
329 extensionCategoriesForClass: aClass |
|
330 ^ aClass organization categories select: [:cat | self isYourClassExtension: cat] |
|
331 ! ! |
|
332 |
|
333 !PackageInfo methodsFor:'listing'! |
|
334 |
|
335 extensionClasses |
|
336 ^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty] |
|
337 ! ! |
|
338 |
|
339 !PackageInfo methodsFor:'listing'! |
|
340 |
|
341 extensionMethods |
|
342 |
|
343 ^ self externalBehaviors gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait] |
|
344 |
|
345 "Modified: / 18-08-2009 / 10:36:44 / Jan Vrany <vranyj1@fel.cvut.cz>" |
|
346 "Modified: / 12-09-2010 / 18:57:23 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
347 ! ! |
|
348 |
|
349 !PackageInfo methodsFor:'testing'! |
|
350 |
|
351 extensionMethodsFromClasses: classes |
|
352 ^classes |
|
353 gather: [:class | self extensionMethodsForClass: class] |
|
354 ! ! |
|
355 |
|
356 !PackageInfo methodsFor:'modifying'! |
|
357 |
|
358 externalBehaviors |
|
359 ^self externalClasses , self externalTraits |
|
360 ! ! |
|
361 |
|
362 !PackageInfo methodsFor:'dependencies'! |
|
363 |
|
364 externalCallers |
|
365 ^ self |
|
366 externalRefsSelect: [:literal | literal isKindOf: Symbol] |
|
367 thenCollect: [:l | l]. |
|
368 ! ! |
|
369 |
|
370 !PackageInfo methodsFor:'dependencies'! |
|
371 |
|
372 externalClasses |
|
373 | myClasses | |
|
374 myClasses := self classesAndMetaClasses asSet. |
|
375 ^ Array streamContents: |
|
376 [:s | |
|
377 Object withAllSubclassesDo: |
|
378 [:class | |
|
379 (class programmingLanguage isSmalltalk not or:[myClasses includes: class]) ifFalse: [s nextPut: class]]] |
|
380 |
|
381 "Modified: / 26-10-2010 / 23:46:18 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
382 ! ! |
|
383 |
|
384 !PackageInfo methodsFor:'naming'! |
|
385 |
|
386 externalName |
|
387 ^ self packageName |
|
388 ! ! |
|
389 |
|
390 !PackageInfo methodsFor:'dependencies'! |
|
391 |
|
392 externalRefsSelect: selBlock thenCollect: colBlock |
|
393 | pkgMethods dependents refs extMethods otherClasses otherMethods classNames | |
|
394 |
|
395 classNames := self classes collect: [:c | c name]. |
|
396 extMethods := self extensionMethods collect: [:mr | mr methodSymbol]. |
|
397 otherClasses := self externalClasses difference: self externalSubclasses. |
|
398 otherMethods := otherClasses gather: [:c | c selectors]. |
|
399 pkgMethods := self methods asSet collect: [:mr | mr methodSymbol]. |
|
400 pkgMethods removeAllFoundIn: otherMethods. |
|
401 |
|
402 dependents := Set new. |
|
403 otherClasses do: [:c | |
|
404 c selectorsAndMethodsDo: |
|
405 [:sel :compiled | |
|
406 (extMethods includes: sel) ifFalse: |
|
407 [refs := compiled literals select: selBlock thenCollect: colBlock. |
|
408 refs do: [:ea | |
|
409 ((classNames includes: ea) or: [pkgMethods includes: ea]) |
|
410 ifTrue: [dependents add: (self referenceForMethod: sel ofClass: c) -> ea]]]]]. |
|
411 ^ dependents |
|
412 ! ! |
|
413 |
|
414 !PackageInfo methodsFor:'dependencies'! |
|
415 |
|
416 externalSubclasses |
|
417 | pkgClasses subClasses | |
|
418 pkgClasses := self classes. |
|
419 subClasses := Set new. |
|
420 pkgClasses do: [:c | subClasses addAll: (c allSubclasses)]. |
|
421 ^ subClasses difference: pkgClasses |
|
422 ! ! |
|
423 |
|
424 !PackageInfo methodsFor:'modifying'! |
|
425 |
|
426 externalTraits |
|
427 | behaviors | |
|
428 |
|
429 ^ Array streamContents: [:s | |
|
430 behaviors := self classesAndMetaClasses. |
|
431 Smalltalk allTraits do: [:trait | |
|
432 (behaviors includes: trait) ifFalse: [s nextPut: trait]. |
|
433 (behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]]. |
|
434 ! ! |
|
435 |
|
436 !PackageInfo methodsFor:'dependencies'! |
|
437 |
|
438 externalUsers |
|
439 ^ self |
|
440 externalRefsSelect: [:literal | literal isVariableBinding] |
|
441 thenCollect: [:l | l key] |
|
442 ! ! |
|
443 |
|
444 !PackageInfo methodsFor:'listing'! |
|
445 |
|
446 foreignClasses |
|
447 | s | |
|
448 s := IdentitySet new. |
|
449 self foreignSystemCategories |
|
450 do: [:c | (SystemOrganization listAtCategoryNamed: c) |
|
451 do: [:cl | |
|
452 | cls | |
|
453 cls := Smalltalk at: cl. |
|
454 s add: cls; |
|
455 add: cls class]]. |
|
456 ^ s |
|
457 ! ! |
|
458 |
|
459 !PackageInfo methodsFor:'testing'! |
|
460 |
|
461 foreignExtensionCategoriesForClass: aClass |
|
462 ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat] |
|
463 ! ! |
|
464 |
|
465 !PackageInfo methodsFor:'testing'! |
|
466 |
|
467 foreignExtensionMethodsForClass: aClass |
|
468 ^ (self foreignExtensionCategoriesForClass: aClass) |
|
469 gather: [:cat | (aClass organization listAtCategoryNamed: cat) |
|
470 collect: [:sel | self referenceForMethod: sel ofClass: aClass]] |
|
471 ! ! |
|
472 |
|
473 !PackageInfo methodsFor:'listing'! |
|
474 |
|
475 foreignSystemCategories |
|
476 ^ SystemOrganization categories |
|
477 reject: [:cat | self includesSystemCategory: cat] |
|
478 ! ! |
|
479 |
|
480 !PackageInfo methodsFor:'comparing'! |
|
481 |
|
482 hash |
|
483 ^ name hash |
|
484 |
|
485 "Modified: / 12-09-2010 / 16:26:55 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
486 ! ! |
|
487 |
|
488 !PackageInfo methodsFor:'testing'! |
|
489 |
|
490 includesClass: aClass |
|
491 ^ self includesSystemCategory: aClass theNonMetaClass category |
|
492 ! ! |
|
493 |
|
494 !PackageInfo methodsFor:'testing'! |
|
495 |
|
496 includesClassNamed: aClassName |
|
497 ^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false]) |
|
498 ! ! |
|
499 |
|
500 !PackageInfo methodsFor:'testing'! |
|
501 |
|
502 includesMethod: aSymbol ofClass: aClass |
|
503 aClass ifNil: [^ false]. |
|
504 ^ self |
|
505 includesMethodCategory: ((aClass organization categoryOfElement: aSymbol) |
|
506 ifNil: [' ']) |
|
507 ofClass: aClass |
|
508 ! ! |
|
509 |
|
510 !PackageInfo methodsFor:'testing'! |
|
511 |
|
512 includesMethodCategory: categoryName ofClass: aClass |
|
513 ^ (self isYourClassExtension: categoryName) |
|
514 or: [(self includesClass: aClass) |
|
515 and: [(self isForeignClassExtension: categoryName) not]] |
|
516 ! ! |
|
517 |
|
518 !PackageInfo methodsFor:'testing'! |
|
519 |
|
520 includesMethodCategory: categoryName ofClassNamed: aClass |
|
521 ^ (self isYourClassExtension: categoryName) |
|
522 or: [(self includesClassNamed: aClass) |
|
523 and: [(self isForeignClassExtension: categoryName) not]] |
|
524 ! ! |
|
525 |
|
526 !PackageInfo methodsFor:'testing'! |
|
527 |
|
528 includesMethodReference: aMethodRef |
|
529 ^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass |
|
530 ! ! |
|
531 |
|
532 !PackageInfo methodsFor:'testing'! |
|
533 |
|
534 includesSystemCategory: categoryName |
|
535 ^ self category: categoryName matches: self systemCategoryPrefix |
|
536 ! ! |
|
537 |
|
538 !PackageInfo methodsFor:'testing'! |
|
539 |
|
540 isForeignClassExtension: categoryName |
|
541 ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not] |
|
542 ! ! |
|
543 |
|
544 !PackageInfo methodsFor:'testing'! |
|
545 |
|
546 isOverrideMethod: aMethodReference |
|
547 ^ aMethodReference category endsWith: '-override' |
|
548 ! ! |
|
549 |
|
550 !PackageInfo methodsFor:'testing'! |
|
551 |
|
552 isYourClassExtension: categoryName |
|
553 ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix] |
|
554 ! ! |
|
555 |
|
556 !PackageInfo methodsFor:'naming'! |
|
557 |
|
558 methodCategoryPrefix |
|
559 " |
|
560 ^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase] |
|
561 " |
|
562 ^ '*', self packageName asLowercase |
|
563 ! ! |
|
564 |
|
565 !PackageInfo methodsFor:'listing'! |
|
566 |
|
567 methods |
|
568 ^ (self extensionMethods, self coreMethods) select: [:method | |
|
569 method isValid |
|
570 and: [method isLocalSelector] |
|
571 and: [method methodSymbol isDoIt not]] |
|
572 ! ! |
|
573 |
|
574 !PackageInfo methodsFor:'testing'! |
|
575 |
|
576 outsideClasses |
|
577 ^ProtoObject withAllSubclasses difference: self classesAndMetaClasses |
|
578 ! ! |
|
579 |
|
580 !PackageInfo methodsFor:'listing'! |
|
581 |
|
582 overrideMethods |
|
583 ^ self extensionMethods select: [:ea | self isOvverideMethod: ea] |
|
584 ! ! |
|
585 |
|
586 !PackageInfo methodsFor:'naming'! |
|
587 |
|
588 packageName |
|
589 " |
|
590 ^ packageName ifNil: [packageName := self categoryName] |
|
591 " |
|
592 ^self categoryName |
|
593 ! ! |
|
594 |
|
595 !PackageInfo methodsFor:'naming'! |
|
596 |
|
597 packageName: aString |
|
598 |
|
599 name := aString |
|
600 |
|
601 "Modified: / 11-09-2010 / 13:25:48 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
602 ! ! |
|
603 |
|
604 !PackageInfo methodsFor:'testing'! |
|
605 |
|
606 referenceForMethod: aSymbol ofClass: aClass |
|
607 ^ MethodReference new setStandardClass: aClass methodSymbol: aSymbol |
|
608 ! ! |
|
609 |
|
610 !PackageInfo methodsFor:'registering'! |
|
611 |
|
612 register |
|
613 PackageOrganizer default registerPackage: self |
|
614 ! ! |
|
615 |
|
616 !PackageInfo methodsFor:'modifying'! |
|
617 |
|
618 removeMethod: aMethodReference |
|
619 ! ! |
|
620 |
|
621 !PackageInfo methodsFor:'listing'! |
|
622 |
|
623 selectors |
|
624 ^ self methods collect: [:ea | ea methodSymbol] |
|
625 ! ! |
|
626 |
|
627 !PackageInfo methodsFor:'listing'! |
|
628 |
|
629 systemCategories |
|
630 |
|
631 ^(Smalltalk allClasses |
|
632 collect: [:cls | cls category] |
|
633 thenSelect:[:cat|cat startsWith: name]) asSet |
|
634 |
|
635 "Modified: / 12-09-2010 / 16:35:51 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
636 ! ! |
|
637 |
|
638 !PackageInfo methodsFor:'naming'! |
|
639 |
|
640 systemCategoryPrefix |
|
641 ^ self packageName |
|
642 ! ! |
|
643 |
|
644 !PackageInfo class methodsFor:'packages access'! |
|
645 |
|
646 allPackages |
|
647 ^PackageOrganizer default packages |
|
648 ! ! |
|
649 |
|
650 !PackageInfo class methodsFor:'compatibility'! |
|
651 |
|
652 default |
|
653 ^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register] |
|
654 ! ! |
|
655 |
|
656 !PackageInfo class methodsFor:'documentation'! |
|
657 |
|
658 documentation |
|
659 " |
|
660 This is a dummy, mimicry class to allow some squeak code to be filed in. |
|
661 Its protocol is neither complete, nor fully compatible with the corresponding |
|
662 squeak original class. |
|
663 " |
|
664 ! ! |
|
665 |
|
666 !PackageInfo class methodsFor:'testing'! |
|
667 |
|
668 existPackageNamed: aString |
|
669 " |
|
670 self existPackageNamed: 'PackageInfo' |
|
671 self existPackageNamed: 'Zork' |
|
672 " |
|
673 ^ (self allPackages anySatisfy: [:each | each packageName = aString]) |
|
674 |
|
675 ! ! |
|
676 |
|
677 !PackageInfo class methodsFor:'initialization'! |
|
678 |
|
679 initialize |
|
680 self allSubclassesDo: [:ea | ea new register] |
|
681 ! ! |
|
682 |
|
683 !PackageInfo class methodsFor:'packages access'! |
|
684 |
|
685 registerPackageName: aString |
|
686 ^ PackageOrganizer default registerPackageNamed: aString |
|
687 ! ! |
|
688 |
|
689 !ProjectDefinition class methodsFor:'code generation'! |
|
690 |
|
691 monticelloTimestamps_code |
|
692 |
|
693 | methodsWithTimestamp | |
|
694 methodsWithTimestamp := OrderedCollection new. |
|
695 |
|
696 self classes do:[:cls| |
|
697 cls methodsDo:[:mthd| |
|
698 (mthd hasAnnotation: #mctimestamp:) ifTrue:[ |
|
699 methodsWithTimestamp add: mthd |
|
700 ] |
|
701 ]. |
|
702 ]. |
|
703 self extensionMethods do:[:mthd| |
|
704 (mthd hasAnnotation: #mctimestamp:) ifTrue:[ |
|
705 methodsWithTimestamp add: mthd |
|
706 ] |
|
707 ]. |
|
708 |
|
709 ^self monticelloTimestamps_codeFor: methodsWithTimestamp |
|
710 |
|
711 " |
|
712 stx_goodies_mondrian_core monticelloTimestamps_code |
|
713 " |
|
714 |
|
715 "Created: / 09-11-2010 / 18:23:49 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
716 ! ! |
|
717 |
|
718 !ProjectDefinition class methodsFor:'code generation'! |
|
719 |
|
720 monticelloTimestamps_codeFor: methods |
|
721 |
|
722 | code | |
|
723 code := String new writeStream. |
|
724 code nextPutAll:'monticelloTimestamps |
|
725 |
|
726 ^#('. |
|
727 methods do:[:mthd| |
|
728 code |
|
729 tab; tab; |
|
730 nextPut:$(; |
|
731 nextPutAll: mthd mclass fullName; |
|
732 space; |
|
733 nextPutAll: mthd selector; |
|
734 space; |
|
735 nextPutAll: (mthd annotationAt: #mctimestamp:) timestamp storeString; |
|
736 nextPut:$); |
|
737 cr. |
|
738 ]. |
|
739 code nextPutAll:' |
|
740 )'. |
|
741 |
|
742 ^code contents |
|
743 |
|
744 " |
|
745 stx_goodies_mondrian_core mcTimestamps_code |
|
746 " |
|
747 |
|
748 "Created: / 09-11-2010 / 18:27:45 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
749 ! ! |
|
750 |
|
751 !SequenceableCollection methodsFor:'*monticello-squeakCompatibility'! |
|
752 |
|
753 copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens |
|
754 "Answer a copy of the receiver in which all occurrences of |
|
755 oldSubstring have been replaced by newSubstring. |
|
756 ifTokens (valid for Strings only) specifies that the characters |
|
757 surrounding the recplacement must not be alphanumeric. |
|
758 Bruce Simth, must be incremented by 1 and not |
|
759 newSubstring if ifTokens is true. See example below. " |
|
760 |
|
761 | aString startSearch currentIndex endIndex | |
|
762 (ifTokens and: [(self isString) not]) |
|
763 ifTrue: [(self isKindOf: Text) ifFalse: [ |
|
764 self error: 'Token replacement only valid for Strings']]. |
|
765 aString := self. |
|
766 startSearch := 1. |
|
767 [(currentIndex := aString indexOfSubCollection: oldSubstring startingAt: startSearch) |
|
768 > 0] |
|
769 whileTrue: |
|
770 [endIndex := currentIndex + oldSubstring size - 1. |
|
771 (ifTokens not |
|
772 or: [(currentIndex = 1 |
|
773 or: [(aString at: currentIndex-1) isAlphaNumeric not]) |
|
774 and: [endIndex = aString size |
|
775 or: [(aString at: endIndex+1) isAlphaNumeric not]]]) |
|
776 ifTrue: [aString := aString |
|
777 copyReplaceFrom: currentIndex |
|
778 to: endIndex |
|
779 with: newSubstring. |
|
780 startSearch := currentIndex + newSubstring size] |
|
781 ifFalse: [ |
|
782 ifTokens |
|
783 ifTrue: [startSearch := currentIndex + 1] |
|
784 ifFalse: [startSearch := currentIndex + newSubstring size]]]. |
|
785 ^ aString |
|
786 |
|
787 "Test case: |
|
788 'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true " |
|
789 |
|
790 "Created: / 26-08-2009 / 12:40:34 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
791 ! ! |
|
792 |
|
793 !Smalltalk class methodsFor:'*monticello-squeakCompatibility'! |
|
794 |
|
795 hasClassNamed:aString |
|
796 Symbol hasInterned:aString |
|
797 ifTrue:[:aSymbol | ^ (self at:aSymbol ifAbsent:[ nil ]) isKindOf:Class ]. |
|
798 ^ false |
|
799 |
|
800 "Created: / 26-08-2009 / 11:43:03 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
801 ! ! |
|
802 |
90 !Stream methodsFor:'*monticello'! |
803 !Stream methodsFor:'*monticello'! |
91 |
804 |
92 isMessageStream |
805 isMessageStream |
93 ^ false |
806 ^ false |
94 ! ! |
807 ! ! |
95 |
808 |
|
809 !String methodsFor:'*monticello-squeakCompatibility'! |
|
810 |
|
811 asStringWithNativeLineEndings |
|
812 |
|
813 ^self copyReplaceAll:Character return with: Character cr |
|
814 |
|
815 "Created: / 12-09-2010 / 16:00:26 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
816 "Modified: / 13-10-2010 / 17:27:38 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
817 ! ! |
|
818 |
|
819 !String methodsFor:'*monticello-squeakCompatibility'! |
|
820 |
|
821 asStringWithSqueakLineEndings |
|
822 |
|
823 ^self copyReplaceAll:Character cr with: Character return |
|
824 |
|
825 "Created: / 12-09-2010 / 16:00:11 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
826 "Modified: / 13-10-2010 / 17:28:10 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
827 ! ! |
|
828 |
96 !String methodsFor:'*monticello'! |
829 !String methodsFor:'*monticello'! |
97 |
830 |
98 extractNumber |
831 extractNumber |
99 ^ ('0', self select: [:ea | ea isDigit]) asNumber |
832 ^ ('0', self select: [:ea | ea isDigit]) asNumber |
100 ! ! |
833 ! ! |
101 |
834 |
|
835 !String methodsFor:'*monticello-squeakCompatibility'! |
|
836 |
|
837 withSqueakLineEndings |
|
838 "Answer a copy of myself in which all sequences of <CR><LF> or <LF> have been changed to <CR>" |
|
839 | newText | |
|
840 (self includes: Character lf) ifFalse: [ ^self copy ]. |
|
841 newText := self copyReplaceAll: String crlf with: String cr. |
|
842 (newText asString includes: Character lf) ifFalse: [ ^newText ]. |
|
843 ^newText copyReplaceAll: String lf with: String cr asTokens: false. |
|
844 |
|
845 "Created: / 26-08-2009 / 11:35:56 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
846 ! ! |
|
847 |
|
848 !StringCollection methodsFor:'converting'! |
|
849 |
|
850 asStringWithNativeLineEndings |
|
851 |
|
852 ^self asString |
|
853 |
|
854 "Created: / 12-09-2010 / 15:58:58 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
855 ! ! |
|
856 |
|
857 !StringCollection methodsFor:'converting'! |
|
858 |
|
859 asStringWithSqueakLineEndings |
|
860 |
|
861 ^ self |
|
862 asStringWith:Character return |
|
863 from:1 to:(self size) |
|
864 compressTabs:false |
|
865 final:nil |
|
866 |
|
867 "Created: / 12-09-2010 / 15:58:41 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
868 ! ! |
|
869 |
|
870 !Symbol methodsFor:'*monticello-squeakCompatibility'! |
|
871 |
|
872 isDoIt |
|
873 ^ (self == #DoIt) or:[ self == #DoItIn: ]. |
|
874 |
|
875 "Created: / 26-08-2009 / 11:46:44 / Jaroslav Havlin <havlij6@fel.cvut.cz>" |
|
876 ! ! |
|
877 |
|
878 !Time class methodsFor:'*monticello'! |
|
879 |
|
880 fromString: aString |
|
881 ^ self readFrom: (ReadStream on: aString). |
|
882 |
|
883 ! ! |
|
884 |
|
885 !Timestamp class methodsFor:'*monticello-instance creation'! |
|
886 |
|
887 fromMethodTimeStamp: aString |
|
888 | stream | |
|
889 stream := ReadStream on: aString. |
|
890 stream skipSeparators. |
|
891 stream skipTo: Character space. |
|
892 ^self readFrom: stream. |
|
893 ! ! |
|
894 |
|
895 !Timestamp class methodsFor:'*monticello-instance creation'! |
|
896 |
|
897 fromString: aString |
|
898 "Answer a new instance for the value given by aString. |
|
899 |
|
900 Timestamp fromString: '1-10-2000 11:55:00 am'. |
|
901 " |
|
902 |
|
903 ^self readFrom: (ReadStream on: aString). |
|
904 ! ! |
|
905 |
|
906 !Timestamp class methodsFor:'*monticello-instance creation'! |
|
907 |
|
908 readFrom: stream |
|
909 | date time | |
|
910 stream skipSeparators. |
|
911 date := Date readFrom: stream. |
|
912 stream skipSeparators. |
|
913 time := Time readFrom: stream. |
|
914 ^self |
|
915 date: date |
|
916 time: time |
|
917 ! ! |
|
918 |
|
919 !Tools::NewSystemBrowser methodsFor:'menu actions-monticello'! |
|
920 |
|
921 projectMenuMonticelloCommit |
|
922 |
|
923 | packageName package workingCopy | |
|
924 packageName := self theSingleSelectedProject. |
|
925 package := MCPackage named: packageName. |
|
926 workingCopy := package workingCopy. |
|
927 MCCommitDialog new |
|
928 workingCopy: workingCopy; |
|
929 open |
|
930 |
|
931 "Created: / 14-09-2010 / 22:54:28 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
932 ! ! |
|
933 |
|
934 !Tools::NewSystemBrowser class methodsFor:'menu specs-monticello'! |
|
935 |
|
936 projectMonticelloMenu |
|
937 "This resource specification was automatically generated |
|
938 by the MenuEditor of ST/X." |
|
939 |
|
940 "Do not manually edit this!! If it is corrupted, |
|
941 the MenuEditor may not be able to read the specification." |
|
942 |
|
943 " |
|
944 MenuEditor new openOnClass:Tools::NewSystemBrowser andSelector:#projectMonticelloMenu |
|
945 (Menu new fromLiteralArrayEncoding:(Tools::NewSystemBrowser projectMonticelloMenu)) startUp |
|
946 " |
|
947 |
|
948 <resource: #menu> |
|
949 |
|
950 ^ |
|
951 #(Menu |
|
952 ( |
|
953 (MenuItem |
|
954 label: 'Commit' |
|
955 itemValue: projectMenuMonticelloCommit |
|
956 translateLabel: true |
|
957 ) |
|
958 (MenuItem |
|
959 label: '-' |
|
960 ) |
|
961 (MenuItem |
|
962 enabled: false |
|
963 label: 'Not yet finished...' |
|
964 translateLabel: true |
|
965 ) |
|
966 ) |
|
967 nil |
|
968 nil |
|
969 ) |
|
970 ! ! |
|
971 |
102 !UndefinedObject methodsFor:'* monticello'! |
972 !UndefinedObject methodsFor:'* monticello'! |
103 |
973 |
104 typeOfClass |
974 typeOfClass |
105 "Necessary to support disjoint class hierarchies." |
975 "Necessary to support disjoint class hierarchies." |
106 |
976 |
107 ^#normal |
977 ^#normal |
108 ! ! |
978 ! ! |
109 |
979 |
|
980 !UserPreferences methodsFor:'accessing-monticello'! |
|
981 |
|
982 mcEnabled |
|
983 |
|
984 ^self at: #mcEnabled ifAbsent: [true]. |
|
985 |
|
986 "Created: / 16-09-2010 / 09:44:32 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
987 "Modified: / 16-09-2010 / 14:50:32 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
988 ! ! |
|
989 |
|
990 !UserPreferences methodsFor:'accessing-monticello'! |
|
991 |
|
992 mcEnabled: aBoolean |
|
993 |
|
994 self at: #mcEnabled put: aBoolean. |
|
995 |
|
996 "Created: / 16-09-2010 / 09:44:16 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
997 ! ! |
|
998 |
|
999 !UserPreferences methodsFor:'accessing-monticello'! |
|
1000 |
|
1001 mcRepositories |
|
1002 |
|
1003 | repos | |
|
1004 repos := self at: #mcRepositories ifAbsent:[#()]. |
|
1005 ^repos decodeAsLiteralArray |
|
1006 |
|
1007 " |
|
1008 self mcRepositories: #() |
|
1009 " |
|
1010 |
|
1011 "Created: / 16-09-2010 / 09:47:22 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
1012 "Modified: / 17-09-2010 / 11:45:01 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
1013 ! ! |
|
1014 |
|
1015 !UserPreferences methodsFor:'accessing-monticello'! |
|
1016 |
|
1017 mcRepositories: aCollection |
|
1018 |
|
1019 | repos | |
|
1020 repos := aCollection literalArrayEncoding. |
|
1021 self at: #mcRepositories put:repos. |
|
1022 MCRepositoryGroup default flushRepositories. |
|
1023 |
|
1024 "Created: / 16-09-2010 / 09:53:33 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
1025 "Modified: / 16-09-2010 / 13:56:15 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
1026 ! ! |
|
1027 |
|
1028 !VersionInfo methodsFor:'accessing'! |
|
1029 |
|
1030 timeStamp |
|
1031 |
|
1032 ^Timestamp |
|
1033 fromDate: (Date fromString: date) |
|
1034 andTime: (Time fromString: time) |
|
1035 |
|
1036 "Created: / 09-09-2010 / 15:20:49 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
1037 ! ! |
|
1038 |
110 !stx_goodies_monticello class methodsFor:'documentation'! |
1039 !stx_goodies_monticello class methodsFor:'documentation'! |
111 |
1040 |
112 extensionsVersion_CVS |
1041 extensionsVersion_CVS |
113 ^ '$Header: /cvs/stx/stx/goodies/monticello/extensions.st,v 1.5 2010-10-30 16:21:27 cg Exp $' |
1042 ^ '$Header: /cvs/stx/stx/goodies/monticello/extensions.st,v 1.6 2011-08-20 14:19:25 cg Exp $' |
114 ! ! |
1043 ! ! |