Author: Anton Gulenko <[email protected]>
Branch: rstrategies
Changeset: r1037:ef35a189c1ff
Date: 2014-08-20 16:13 +0200
http://bitbucket.org/pypy/lang-smalltalk/changeset/ef35a189c1ff/
Log: Merged.
diff too long, truncating to 2000 out of 364571 lines
diff --git a/images/Squeak4.5-12568.changes b/images/Squeak4.5-12568.changes
deleted file mode 100644
--- a/images/Squeak4.5-12568.changes
+++ /dev/null
@@ -1,39 +0,0 @@
-'From Squeak4.1 of 17 April 2010 [latest update: #9957] on 17 April 2010 at
5:22:05 pm'!
----STARTUP----{17 April 2010 . 5:21:54 pm} as
C:\Squeak\4.0\4.1-final\Squeak4.1.image!
Smalltalk appendChangesTo: 'SqueakV41.sources'.!
----QUIT----{17 April 2010 . 5:22:11 pm} Squeak4.1.image priorSource: 89!
----STARTUP----{24 May 2010 . 8:07:26 pm} as C:\Squeak\4.2\Squeak4.1.image!
----SNAPSHOT----{24 May 2010 . 8:08:14 pm} Squeak4.2.image priorSource: 229!
!HashedCollection commentStamp: 'ul 4/12/2010 22:37' prior: 0!
I am an abstract collection of objects that implement hash and equality in a
consitent way. This means that whenever two objects are equal, their hashes
have to be equal too. If two objects are equal then I can only store one of
them. Hashes are expected to be integers (preferably SmallIntegers). I also
expect that the objects contained by me do not change their hashes. If that
happens, hash invariants have to be re-established, which can be done by
#rehash.
Since I'm abstract, no instances of me should exist. My subclasses should
implement #scanFor:, #fixCollisionsFrom: and #noCheckNoGrowFillFrom:.
Instance Variables
array: <ArrayedCollection> (typically Array or WeakArray)
tally: <Integer> (non-negative)
array
- An array whose size is a prime number, it's non-nil elements are the
elements of the collection, and whose nil elements are empty slots. There is
always at least one nil. In fact I try to keep my "load" at 75% or less so that
hashing will work well.
tally
- The number of elements in the collection. The array size is always
greater than this.
Implementation details:
I implement a hash table which uses open addressing with linear probing as the
method of collision resolution. Searching for an element or a free slot for an
element is done by #scanFor: which should return the index of the slot in array
corresponding to it's argument. When an element is removed #fixCollisionsFrom:
should rehash all elements in array between the original index of the removed
element, wrapping around after the last slot until reaching an empty slot. My
maximum load factor (75%) is hardcoded in #atNewIndex:put:, so it can only be
changed by overriding that method. When my load factor reaches this limit I
replace my array with a larger one (see #grow) ensuring that my load factor
will be less than or equal to 50%. The new array is filled by
#noCheckNoGrowFillFrom: which should use #scanForEmptySlotFor: instead of
#scanFor: for better performance. I do not shrink.
!
!WeakKeyDictionary methodsFor: 'private' stamp: 'ul 4/12/2010 22:59'!
compact
"Reduce the size of array so that the load factor will be ~75%."
| newCapacity |
newCapacity := self class goodPrimeAtLeast: self slowSize * 4 // 3.
self growTo: newCapacity! !
!Collection methodsFor: 'adding' stamp: 'ul 4/12/2010 22:33' prior: 18816249!
add: newObject withOccurrences: anInteger
"Add newObject anInteger times to the receiver. Do nothing if anInteger
is less than one. Answer newObject."
anInteger timesRepeat: [self add: newObject].
^ newObject! !
!HashedCollection class methodsFor: 'initialize-release' stamp: 'ul 4/12/2010
23:49'!
compactAll
"HashedCollection compactAll"
self allSubclassesDo: #compactAllInstances! !
!HashedCollection class methodsFor: 'initialize-release' stamp: 'ul 4/12/2010
23:49'!
compactAllInstances
"Do not use #allInstancesDo: because compact may create new instances."
self allInstances do: #compact! !
!HashedCollection class methodsFor: 'sizing' stamp: 'ul 4/7/2010 00:17' prior:
55063414!
goodPrimes
"Answer a sorted array of prime numbers less than one billion that make
good
hash table sizes. Should be expanded as needed. See comments below
code"
^#(
5 11 17 23 31 43 59 79 107 149 199 269 359 479 641 857 1151
1549 2069
2237 2423 2617 2797 2999 3167 3359 3539 3727 3911
4441 4787 5119 5471 5801 6143 6521 6827 7177 7517 7853
8783 9601 10243 10867 11549 12239 12919 13679 14293 15013 15731
17569 19051 20443 21767 23159 24611 25847 27397 28571 30047
31397
35771 38201 40841 43973 46633 48989 51631 54371 57349 60139
62969
70589 76091 80347 85843 90697 95791 101051 106261 111143 115777
120691 126311
140863 150523 160969 170557 181243 190717 201653 211891 221251
232591 242873 251443
282089 300869 321949 341227 362353 383681 401411 422927 443231
464951 482033 504011
562621 605779 647659 681607 723623 763307 808261 844709 886163
926623 967229 1014617
1121987 1201469 1268789 1345651 1429531 1492177 1577839 1651547
1722601 1800377 1878623 1942141 2028401
2242727 2399581 2559173 2686813 2836357 3005579 3144971 3283993
3460133 3582923 3757093 3903769 4061261
4455361 4783837 5068529 5418079 5680243 6000023 6292981 6611497
6884641 7211599 7514189 7798313 8077189
9031853 9612721 10226107 10745291 11338417 11939203 12567671
13212697 13816333 14337529 14938571 15595673 16147291
17851577 18993941 20180239 21228533 22375079 23450491 24635579
25683871 26850101 27921689 29090911 30153841 31292507 32467307
35817611 37983761 40234253 42457253 44750177 46957969 49175831
51442639 53726417 55954637 58126987 60365939 62666977 64826669
71582779 76039231 80534381 84995153 89500331 93956777 98470819
102879613 107400389 111856841 116365721 120819287 125246581 129732203
143163379 152076289 161031319 169981667 179000669 187913573
196826447 205826729 214748357 223713691 232679021 241591901 250504801 259470131
285162679 301939921 318717121 335494331 352271573 369148753
385926017 402603193 419480419 436157621 453034849 469712051 486589307 503366497
520043707
570475349 603929813 637584271 671138659 704693081 738247541
771801929 805356457 838910803 872365267 905919671 939574117 973128521
1006682977 1040137411
1073741833)
"The above primes past 2069 were chosen carefully so that they do not interact
badly with 1664525 (used by hashMultiply), and so that gcd(p, (256^k) +/- a) =
1, for 0<a<=32 and 0<k<=8. See Knuth's TAOCP for details."
"The above primes also try to map the values of ((0 to: 4095) collect: [ :each
| each << 18 \\ prime ]) sort to an equidistant sequence of numbers. This helps
to avoid the collision of chains in identity-based hashed collections. To do
that they were chosen to return a low value when the following block is
evaluated with them as argument:
[ :prime |
| slots cost optimalDistance previous |
slots := Array new: 4097.
0 to: 4095 do: [ :ea | slots at: ea + 1 put: ea * 262144 \\ prime ].
slots at: 4097 put: prime.
slots sort.
cost := 0.
optimalDistance := prime // 4096.
2 to: 4097 do: [ :index |
| newCost |
newCost := optimalDistance - ((slots at: index) - (slots at:
index - 1)).
newCost > cost ifTrue: [ cost := newCost ] ].
cost ]."! !
!HashedCollection methodsFor: 'adding' stamp: 'ul 4/12/2010 22:38' prior:
53647096!
add: newObject withOccurrences: anInteger
"Add newObject anInteger times to the receiver. Do nothing if anInteger
is less than one. Answer newObject."
anInteger < 1 ifTrue: [ ^newObject ].
^self add: newObject "I can only store an object once."
! !
!HashedCollection methodsFor: 'private' stamp: 'ul 4/12/2010 22:53'!
compact
"Reduce the size of array so that the load factor will be ~75%."
| newCapacity |
newCapacity := self class goodPrimeAtLeast: tally * 4 // 3.
self growTo: newCapacity! !
!WeakSet methodsFor: 'private' stamp: 'ul 4/12/2010 22:59'!
compact
"Reduce the size of array so that the load factor will be ~75%."
| newCapacity |
newCapacity := self class goodPrimeAtLeast: self slowSize * 4 // 3.
self growTo: newCapacity! !
!Symbol class methodsFor: 'class initialization' stamp: 'ul 4/13/2010 00:00'
prior: 30357901!
compactSymbolTable
"Reduce the size of the symbol table so that it holds all existing
symbols with 25% free space."
| oldSize |
Smalltalk garbageCollect.
oldSize := SymbolTable capacity.
SymbolTable compact.
^(oldSize - SymbolTable capacity) printString, ' slot(s) reclaimed'! !
KeyedIdentitySet class removeSelector: #goodPrimes!
WeakIdentityKeyDictionary class removeSelector: #goodPrimes!
IdentitySet class removeSelector: #goodPrimes!
IdentityDictionary class removeSelector: #goodPrimes!
"Collections"!
!HashedCollectionTest methodsFor: 'test - class - sizing' stamp: 'ul 4/7/2010
00:18' prior: 58761579!
testPrimes: primes
| badPrimes |
badPrimes := #(3 5 71 139 479 5861 277421). "These primes are less than
the hashMultiply constant (1664525) and 1664525 \\ prime is close to 0 (mod
prime). The following snippet reproduces these numbers:
| hashMultiplyConstant |
hashMultiplyConstant := 1 hashMultiply.
(Integer primesUpTo: hashMultiplyConstant) select: [ :each |
| remainder |
remainder := hashMultiplyConstant \\ each.
remainder <= 1 or: [ remainder + 1 = each ] ]."
self assert: primes isSorted.
primes do: [ :each |
self assert: each isPrime.
self deny: (each > 2069 and: [ badPrimes includes: each ]) ].
self assert: (
primes select: [ :p |
| result |
result := false.
p > 2069 ifTrue: [
1 to: 8 do: [ :k |
1 to: 32 do: [ :a |
(p gcd: (256 raisedTo: k) + a) = 1
ifFalse: [
result := true ].
(p gcd: (256 raisedTo: k) - a) = 1
ifFalse: [
result := true ] ] ] ].
result ]) isEmpty.! !
HashedCollectionTest removeSelector:
#testGoodPrimesForIdentityBasedHashedCollections!
"CollectionsTests"!
!MCMczReader methodsFor: 'as yet unclassified' stamp: 'bf 4/18/2010 18:38'
prior: 22938947!
extractInfoFrom: dict
^MCWorkingCopy infoFromDictionary: dict cache: self infoCache! !
!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'bf 4/19/2010
00:39' prior: 23215403!
infoFromDictionary: aDictionary cache: cache
| id |
id := (aDictionary at: #id) asString.
^ cache at: id ifAbsentPut:
[MCVersionInfo
name: (aDictionary at: #name ifAbsent: [''])
id: (UUID fromString: id)
message: (aDictionary at: #message ifAbsent: [''])
date: ([Date fromString: (aDictionary at: #date)]
ifError: [nil])
time: ([Time fromString: (aDictionary at: #time)]
ifError: [nil])
author: (aDictionary at: #author ifAbsent: [''])
ancestors: (self ancestorsFromArray: (aDictionary at:
#ancestors ifAbsent: []) cache: cache)
stepChildren: (self ancestorsFromArray: (aDictionary
at: #stepChildren ifAbsent: []) cache: cache)]! !
!MCVersionInfo methodsFor: 'converting' stamp: 'bf 4/18/2010 23:25' prior:
23175569!
asDictionary
^ Dictionary new
at: #name put: name;
at: #id put: id asString;
at: #message put: message;
at: #date put: date;
at: #time put: time;
at: #author put: author;
at: #ancestors put: (self ancestors collect: [:a | a
asDictionary]);
yourself! !
"Monticello"!
!BlockContextTest methodsFor: 'running' stamp: 'md 9/6/2005 19:56' prior:
50431957!
setUp
super setUp.
aBlockContext := [100@100 corner: 200@200].
contextOfaBlockContext := thisContext.! !
!BehaviorTest methodsFor: 'tests' stamp: 'md 2/18/2006 16:42' prior: 17365994!
testBinding
self assert: Object binding value = Object.
self assert: Object binding key = #Object.
self assert: Object class binding value = Object class.
"returns nil for Metaclasses... like Encoder>>#associationFor:"
self assert: Object class binding key = nil.! !
!CompledMethodTrailerTest methodsFor: 'testing' stamp: 'Igor.Stasenko
12/13/2009 21:13' prior: 53956757!
testEmbeddingSourceCode
| trailer newTrailer code |
trailer := CompiledMethodTrailer new.
code := 'foo'.
trailer sourceCode: code.
newTrailer := trailer testEncoding.
self assert: (trailer kind == #EmbeddedSourceQCompress ).
self assert: (newTrailer sourceCode = code).
"the last bytecode index must be at 0"
self assert: (newTrailer endPC = 0).
code := 'testEmbeddingSourceCode
| trailer newTrailer code |
trailer := CompiledMethodTrailer new.
trailer sourceCode: code.
newTrailer := trailer testEncoding.
self assert: (newTrailer sourceCode = code).'.
trailer sourceCode: code.
self assert: (trailer kind == #EmbeddedSourceZip ).
newTrailer := trailer testEncoding.
self assert: (newTrailer sourceCode = code).
"the last bytecode index must be at 0"
self assert: (newTrailer endPC = 0).
! !
!CompledMethodTrailerTest methodsFor: 'testing' stamp: 'Igor.Stasenko
12/13/2009 21:13' prior: 53957691!
testEmbeddingTempNames
| trailer newTrailer code |
trailer := CompiledMethodTrailer new.
code := 'foo'.
trailer tempNames: code.
newTrailer := trailer testEncoding.
self assert: (trailer kind == #TempsNamesQCompress ).
self assert: (newTrailer tempNames = code).
"the last bytecode index must be at 0"
self assert: (newTrailer endPC = 0).
code := 'testEmbeddingSourceCode
| trailer newTrailer code |
trailer := CompiledMethodTrailer new.
trailer sourceCode: code.
newTrailer := trailer testEncoding.
self assert: (newTrailer sourceCode = code).'.
trailer tempNames: code.
self assert: (trailer kind == #TempsNamesZip ).
newTrailer := trailer testEncoding.
self assert: (newTrailer tempNames = code).
"the last bytecode index must be at 0"
self assert: (newTrailer endPC = 0).
! !
!CompledMethodTrailerTest methodsFor: 'testing' stamp: 'Igor.Stasenko
12/13/2009 21:17' prior: 53958613!
testEncodingNoTrailer
| trailer |
trailer := CompiledMethodTrailer new.
"by default it should be a no-trailer"
self assert: (trailer kind == #NoTrailer ).
self assert: (trailer size = 1).
trailer := trailer testEncoding.
self assert: (trailer kind == #NoTrailer ).
self assert: (trailer size = 1).
"the last bytecode index must be at 0"
self assert: (trailer endPC = 0).
! !
!CompledMethodTrailerTest methodsFor: 'testing' stamp: 'Igor.Stasenko
12/13/2009 21:14' prior: 53959109!
testEncodingSourcePointer
| trailer |
trailer := CompiledMethodTrailer new.
CompiledMethod allInstancesDo: [:method | | ptr |
trailer method: method.
self assert: ( (ptr := method sourcePointer) == trailer
sourcePointer).
"the last bytecode index must be at 0"
ptr ~= 0 ifTrue: [
self assert: (method endPC = trailer endPC) ].
].! !
!CompledMethodTrailerTest methodsFor: 'testing' stamp: 'Igor.Stasenko
12/13/2009 21:15' prior: 53959564!
testEncodingVarLengthSourcePointer
| trailer newTrailer |
trailer := CompiledMethodTrailer new.
trailer sourcePointer: 1.
newTrailer := trailer testEncoding.
self assert: (newTrailer sourcePointer = 1).
trailer sourcePointer: 16r100000000000000.
newTrailer := trailer testEncoding.
self assert: (newTrailer sourcePointer = 16r100000000000000).
"the last bytecode index must be at 0"
self assert: (newTrailer endPC = 0).
! !
!CompledMethodTrailerTest methodsFor: 'testing' stamp: 'Igor.Stasenko
12/13/2009 21:15' prior: 53960108!
testSourceByIdentifierEncoding
| trailer id |
trailer := CompiledMethodTrailer new.
id := UUID new asString.
trailer sourceIdentifier: id.
self assert: (trailer kind == #SourceByStringIdentifier ).
trailer := trailer testEncoding.
self assert: (trailer kind == #SourceByStringIdentifier ).
self assert: (trailer sourceIdentifier = id).
"the last bytecode index must be at 0"
self assert: (trailer endPC = 0).
! !
!CompledMethodTrailerTest methodsFor: 'testing' stamp: 'Igor.Stasenko
12/13/2009 21:49' prior: 53960643!
testSourceBySelectorEncoding
| trailer |
trailer := CompiledMethodTrailer new.
trailer setSourceBySelector.
self assert: (trailer kind == #SourceBySelector ).
self assert: (trailer size = 1).
trailer := trailer testEncoding.
self assert: (trailer kind == #SourceBySelector ).
self assert: (trailer size = 1).
"the last bytecode index must be at 0"
self assert: (trailer endPC = 0).
! !
!CategorizerTest methodsFor: 'running' stamp: 'mtf 9/10/2007 10:10' prior:
18074036!
setUp
categorizer := Categorizer defaultList: #(a b c d e).
categorizer classifyAll: #(a b c) under: 'abc'.
categorizer addCategory: 'unreal'.! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 10:17' prior:
18074267!
testClassifyNewElementNewCategory
categorizer classify: #f under: #nice.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' a b c)
(''unreal'')
(''nice'' f)
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 10:18' prior:
18074541!
testClassifyNewElementOldCategory
categorizer classify: #f under: #unreal.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' a b c)
(''unreal'' f)
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 10:17' prior:
18074806!
testClassifyOldElementNewCategory
categorizer classify: #e under: #nice.
self assert: categorizer printString =
'(''as yet unclassified'' d)
(''abc'' a b c)
(''unreal'')
(''nice'' e)
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 12:54' prior:
18075078!
testClassifyOldElementOldCategory
categorizer classify: #e under: #unreal.
self assert: categorizer printString =
'(''as yet unclassified'' d)
(''abc'' a b c)
(''unreal'' e)
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 10:22' prior:
18075341!
testDefaultCategoryIsTransient
"Test that category 'as yet unclassified' disapears when all it's
elements are removed'"
categorizer classifyAll: #(d e) under: #abc.
self assert: categorizer printString =
'(''abc'' a b c d e)
(''unreal'')
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/11/2007 15:15' prior:
18075669!
testNullCategory
"Test that category 'as yet unclassified' disapears when all it's
elements are removed'"
| aCategorizer |
aCategorizer := Categorizer defaultList: #().
self assert: aCategorizer printString =
'(''as yet unclassified'')
'.
self assert: aCategorizer categories = #('no messages').
aCategorizer classify: #a under: #b.
self assert: aCategorizer printString =
'(''b'' a)
'.
self assert: aCategorizer categories = #(b).! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 12:57' prior:
18076194!
testRemoveEmptyCategory
categorizer removeCategory: #unreal.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' a b c)
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 12:55' prior:
18076430!
testRemoveExistingElement
categorizer removeElement: #a.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' b c)
(''unreal'')
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 12:59' prior:
18076673!
testRemoveNonEmptyCategory
self should: [categorizer removeCategory: #abc] raise: Error.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' a b c)
(''unreal'')
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 12:59' prior:
18076950!
testRemoveNonExistingCategory
categorizer removeCategory: #nice.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' a b c)
(''unreal'')
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 12:57' prior:
18077203!
testRemoveNonExistingElement
categorizer removeElement: #f.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' a b c)
(''unreal'')
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/11/2007 14:49' prior:
18077451!
testRemoveThenRename
categorizer removeCategory: #unreal.
categorizer renameCategory: #abc toBe: #unreal.
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''unreal'' a b c)
'! !
!CategorizerTest methodsFor: 'testing' stamp: 'mtf 9/10/2007 10:14' prior:
18077736!
testUnchanged
self assert: categorizer printString =
'(''as yet unclassified'' d e)
(''abc'' a b c)
(''unreal'')
'! !
"KernelTests"!
!SmalltalkImage methodsFor: 'accessing' stamp: 'ul 4/18/2010 22:22'!
at: key ifPresentAndInMemory: aBlock
"Lookup the given key in the receiver. If it is present, answer the
value of evaluating the given block with the value associated with the key.
Otherwise, answer nil."
^globals at: key ifPresentAndInMemory: aBlock! !
!SmalltalkImage methodsFor: 'image' stamp: 'dtl 4/11/2010 11:45'!
image
"Answer the object to query about the current object memory and
execution environment."
^self! !
!SmalltalkImage methodsFor: 'image' stamp: 'dtl 4/11/2010 11:47'!
imageFormatVersion
"Answer an integer identifying the type of image. The image version
number may
identify the format of the image (e.g. 32 or 64-bit word size) or
specific requirements
of the image (e.g. block closure support required). This invokes an
optional primitive
that may not be available on all virtual machines."
"Smalltalk image imageFormatVersion"
<primitive: 'primitiveImageFormatVersion'>
self notify: 'This virtual machine does not support the optional
primitive #primitiveImageFormatVersion' translated.
^''! !
!SmalltalkImage methodsFor: 'vm' stamp: 'dtl 4/11/2010 11:38'!
interpreterSourceVersion
"Answer a string corresponding to the version of the interpreter source.
This represents the version level of the Smalltalk source code
(interpreter
and various plugins) that is translated to C by a CCodeGenerator, as
distinct
from the external platform source code, typically written in C and
managed
separately for each platform. An optional primitive is invoked that may
not
be available on all virtual machines."
"Smalltalk vm interpreterSourceVersion"
<primitive: 'primitiveInterpreterSourceVersion'>
self notify: 'This virtual machine does not support the optional
primitive #primitiveInterpreterSourceVersion' translated.
^''! !
!SmalltalkImage methodsFor: 'vm' stamp: 'dtl 4/11/2010 11:39'!
platformSourceVersion
"Answer a string corresponding to the version of the external platform
source
code, typically written in C and managed separately for each platform.
This
invokes an optional primitive that may not be available on all virtual
machines."
"Smalltalk vm platformSourceVersion"
<primitive: 'primitivePlatformSourceVersion'>
self notify: 'This virtual machine does not support the optional
primitive #primitivePlatformSourceVersion' translated.
^''! !
!SmalltalkImage methodsFor: 'image' stamp: 'md 5/16/2006 12:34' prior: 58536670!
version
"Answer the version of this release."
^SystemVersion current version! !
!SmalltalkImage methodsFor: 'vm' stamp: 'dtl 4/11/2010 11:39'!
versionLabel
"Answer a string corresponding to the version of virtual machine. This
represents the version level of the Smalltalk source code (interpreter
and various plugins) that is translated to C by a CCodeGenerator, in
addition to the external platform source code, typically written in C
and
managed separately for each platform.
This invokes an optional primitive that may not be available on all
virtual
machines. See also vmVersion, which answers a string identifying the
image
from which virtual machine sources were generated."
"Smalltalk vm versionLabel"
<primitive: 'primitiveVMVersion'>
self notify: 'This virtual machine does not support the optional
primitive #primitiveVMVersion' translated.
^''! !
!SmalltalkImage methodsFor: 'vm' stamp: 'dtl 4/11/2010 11:15'!
vm
"Answer the object to query about virtual machine."
^self! !
!SmalltalkImage methodsFor: 'image' stamp: 'dtl 1/4/2010 21:40' prior: 58537225!
wordSize
"Answer the size in bytes of an object pointer or word in the object
memory.
The value does not change for a given image, but may be modified by a
SystemTracer
when converting the image to another format. The value is cached in
WordSize to
avoid the performance overhead of repeatedly consulting the VM."
"Smalltalk wordSize"
^ WordSize ifNil: [WordSize := [SmalltalkImage current vmParameterAt:
40] on: Error do: [4]]! !
"System"!
!SMLoaderPlus commentStamp: 'btr 12/1/2006 15:16' prior: 0!
A simple package loader that is currently the standard UI for SqueakMap (the
model is an SMSqueakMap instance). It uses ToolBuilder to construct its window.
You can open one with:
SMLoaderPlus open
Instance Variables
categoriesToFilterIds: <OrderedCollection> The set of
categories to filter the packages list.
filters: <OrderedCollection> The set of
filters to apply to the packages list.
map: <SMSqueakMap> The model SqueakMap.
packagesList: <OrderedCollection> The list of packages from
the map.
selectedCategory: <SMCategory> The current category.
selectedItem: <SMPackage> The selected package or
release.
window: <PluggableSystemWindow> The window, held only
so we can reOpen.!
!SMLoaderCategoricalPlus commentStamp: 'btr 12/4/2006 15:47' prior: 0!
A variant package loader that uses a more-or-less standard Smalltalk-80 browser
perspective of selecting categories in one pane and then selecting items within
in the next pane.
You can open one with:
SMLoaderCategoricalPlus open!
!SMLoader commentStamp: 'btr 11/30/2006 18:00' prior: 27913009!
A simple package loader that is currently the standard UI for SqueakMap (the
model is an SMSqueakMap instance).
You can open one with:
SMLoader open!
!SMLoaderCategorical commentStamp: 'btr 12/1/2006 15:16' prior: 0!
A variant package loader that uses a more-or-less standard Smalltalk-80 browser
perspective of selecting categories in one pane and then selecting items within
in the next pane.
You can open one with:
SMLoaderCategorical open!
!SMLoaderCategoricalPlus class methodsFor: 'menu registration' stamp: 'btr
12/1/2006 18:06'!
initialize
Smalltalk at: #ToolBuilder ifPresent: [:tb |
(TheWorldMenu respondsTo: #registerOpenCommand:)
ifTrue: [TheWorldMenu registerOpenCommand: {self
openMenuString. {self. #open}}]]! !
!SMLoaderCategoricalPlus class methodsFor: 'menu registration' stamp: 'btr
12/1/2006 17:34'!
openMenuString
^ 'SqueakMap Categories'! !
!SMLoaderCategoricalPlus class methodsFor: 'menu registration' stamp: 'btr
12/1/2006 17:34'!
removeFromSystem
(TheWorldMenu respondsTo: #registerOpenCommand:)
ifTrue: [TheWorldMenu unregisterOpenCommand: self
openMenuString].
self removeFromSystem: true! !
!SMLoaderCategoricalPlus class methodsFor: 'menu registration' stamp: 'btr
12/1/2006 17:34'!
unload
(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue:
[TheWorldMenu unregisterOpenCommand: self openMenuString].! !
!SMLoaderCategoricalPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:50'!
buildFancyWith: aBuilder
"Creates a variant of the window where the package pane is split
between installed and uninstalled packages."
| buttonBarHeight searchHeight vertDivide horizDivide |
buttonBarHeight := 0.07.
searchHeight := 0.07.
vertDivide := 0.5.
horizDivide := 0.6.
builder := aBuilder.
window := builder build: (builder pluggableWindowSpec new model: self;
label: #label;
children: (OrderedCollection new add:
((self buildButtonBarWith: builder)
frame: (0 @ 0 corner: 1 @
buttonBarHeight); yourself);
add: ((self buildCategoriesListWith: builder)
frame: (0 @ buttonBarHeight corner:
vertDivide @ horizDivide); yourself);
add: ((self buildSearchPaneWith: builder)
frame: (vertDivide @ buttonBarHeight
corner: 1 @ (buttonBarHeight + searchHeight)); yourself);
add: ((self buildNotInstalledPackagesListWith:
builder)
frame: (vertDivide @ (buttonBarHeight +
searchHeight) corner: 1 @ (horizDivide / 2)); yourself);
add: ((self buildInstalledPackagesListWith:
builder)
frame: (vertDivide @ (horizDivide / 2)
corner: 1 @ horizDivide); yourself);
add: ((self buildPackagePaneWith: builder)
frame: (0 @ horizDivide corner: 1 @ 1);
yourself); yourself)).
window on: #mouseEnter send: #paneTransition: to: window.
window on: #mouseLeave send: #paneTransition: to: window.
self setUpdatablePanesFrom: #(#installedPackageList
#notInstalledPackageList ).
currentPackageList := #notInstalled.
window extent: self initialExtent.
^ window! !
!SMLoaderCategoricalPlus methodsFor: 'interface' stamp: 'btr 12/1/2006 17:56'!
buildInstalledPackagesListWith: aBuilder
^ aBuilder pluggableTreeSpec new model: self;
roots: #installedPackageList;
getSelectedPath: #selectedItemPath;
setSelected: #selectedItem:;
menu: #packagesMenu:;
label: #itemLabel:;
getChildren: #itemChildren:;
hasChildren: #itemHasChildren:;
autoDeselect: true;
wantsDrop: true;
yourself! !
!SMLoaderCategoricalPlus methodsFor: 'interface' stamp: 'btr 12/1/2006 17:52'!
buildNotInstalledPackagesListWith: aBuilder
^ aBuilder pluggableTreeSpec new model: self;
roots: #notInstalledPackageList;
getSelectedPath: #selectedItemPath;
setSelected: #selectedItem:;
menu: #packagesMenu:;
label: #itemLabel:;
getChildren: #itemChildren:;
hasChildren: #itemHasChildren:;
autoDeselect: true;
wantsDrop: true;
yourself! !
!SMLoaderCategoricalPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:55'!
buildWith: aBuilder
| buttonBarHeight searchHeight vertDivide horizDivide |
buttonBarHeight := 0.07.
searchHeight := 0.07.
vertDivide := 0.5.
horizDivide := 0.6.
builder := aBuilder.
window := builder build: (builder pluggableWindowSpec new model: self;
label: #label;
children: (OrderedCollection new add:
((self buildButtonBarWith: builder)
frame: (0 @ 0 corner: 1 @
buttonBarHeight); yourself);
add: ((self buildCategoriesListWith: builder)
frame: (0 @ buttonBarHeight corner:
vertDivide @ horizDivide); yourself);
add: ((self buildSearchPaneWith: builder)
frame: (vertDivide @ buttonBarHeight
corner: 1 @ (buttonBarHeight + searchHeight)));
add: ((self buildPackagesListWith: builder)
frame: (vertDivide @ (buttonBarHeight +
searchHeight) corner: 1 @ horizDivide));
add: ((self buildPackagePaneWith: builder)
frame: (0 @ horizDivide corner: 1 @
1)); yourself)).
window on: #mouseEnter send: #paneTransition: to: window.
window on: #mouseLeave send: #paneTransition: to: window.
window extent: self initialExtent.
^ window! !
!SMLoaderCategoricalPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 17:34'!
currentPackageList
^currentPackageList! !
!SMLoaderCategoricalPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 17:34'!
currentPackageList: aSymbol
currentPackageList := aSymbol.
self changed: #installButtonLabel.! !
!SMLoaderCategoricalPlus methodsFor: 'interface' stamp: 'btr 12/4/2006 15:55'!
defaultLabel
^ 'Categorical ' , super defaultLabel! !
!SMLoaderCategoricalPlus methodsFor: 'interface' stamp: 'btr 12/4/2006 15:58'!
installButtonLabel
^ self currentPackageList = #notInstalled
ifTrue: ['Install the above package']
ifFalse: ['Remove the above package']! !
!SMLoaderCategoricalPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 17:52'!
installedPackageList
^self packageList select: [:e | e isInstalled]! !
!SMLoaderCategoricalPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 18:02'!
installedPackagesListIndex
^ self currentPackageList = #installed
ifTrue: [self packagesListIndex]
ifFalse: [0]! !
!SMLoaderCategoricalPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 17:34'!
installedPackagesListIndex: anObject
packagesListIndex := anObject.
self currentPackageList ~= #installed
ifTrue: [self currentPackageList: #installed.
self changed: #currentPackageList].
self noteChanged! !
!SMLoaderCategoricalPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 17:34'!
isOn
^false! !
!SMLoaderCategoricalPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 17:53'!
notInstalledPackageList
^self packageList reject: [:e | e isInstalled]! !
!SMLoaderCategoricalPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 18:02'!
notInstalledPackagesListIndex
^ self currentPackageList = #notInstalled
ifTrue: [self packagesListIndex]
ifFalse: [0]! !
!SMLoaderCategoricalPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 18:03'!
notInstalledPackagesListIndex: anObject
packagesListIndex := anObject.
self currentPackageList ~= #notInstalled ifTrue:
[self currentPackageList: #notInstalled.
self changed: #currentPackageList].
self changed: #packagesListIndex.
"update my selection"
self noteChanged.
self contentsChanged! !
!SMLoaderCategoricalPlus methodsFor: 'private' stamp: 'btr 12/1/2006 17:53'!
noteChanged
self changed: #installedPackageList.
self changed: #notInstalledPackageList.
super noteChanged."
self changed: #packageNameList.
self changed: #packagesListIndex.
self changed: #categoriesForPackage.
self contentsChanged."! !
!SMLoaderCategoricalPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 17:34'!
packageList
^ self packages
select: [:e | (e categories
anySatisfy: [:cat | cat = self
selectedCategory])
and: [(filters ifNil: [#()])
allSatisfy: [:currFilter |
(self perform: currFilter)
value: e]]]! !
!SMLoaderPlus class methodsFor: 'parts bin' stamp: 'btr 11/22/2006 15:02'!
descriptionForPartsBin
^self partName: 'Package Loader'
categories: #(Tools)
documentation: 'SqueakMap UI'
! !
!SMLoaderPlus class methodsFor: 'class initialization' stamp: 'btr 12/1/2006
15:47'!
initialize
"Hook us up in the world menu."
"self initialize"
Smalltalk at: #ToolBuilder ifPresent: [:tb |
self registerInFlapsRegistry.
(Preferences windowColorFor: #SMLoader) = Color white "not set"
ifTrue: [ Preferences setWindowColorFor: #SMLoader to:
(Color colorFrom: self windowColorSpecification brightColor) ].
(TheWorldMenu respondsTo: #registerOpenCommand:)
ifTrue: [| oldCmds |
oldCmds := TheWorldMenu registry select: [:cmd
| cmd first includesSubString: 'Package Loader'].
oldCmds do: [:cmd | TheWorldMenu
unregisterOpenCommand: cmd first].
TheWorldMenu registerOpenCommand: {self openMenuString.
{self. #open}}]].
DefaultFilters := OrderedCollection new.
DefaultCategoriesToFilterIds := OrderedCollection new! !
!SMLoaderPlus class methodsFor: 'new-morph participation' stamp: 'btr
11/22/2006 15:16'!
initializedInstance
^ (ToolBuilder open: self new) extent: 400@400! !
!SMLoaderPlus class methodsFor: 'instance creation' stamp: 'btr 11/22/2006
15:02'!
new
"Create a SqueakMap loader on the default map."
^self newOn: SMSqueakMap default! !
!SMLoaderPlus class methodsFor: 'instance creation' stamp: 'btr 11/22/2006
15:02'!
newOn: aMap
"Create a SqueakMap loader on given map."
^super new on: aMap; yourself! !
!SMLoaderPlus class methodsFor: 'new-morph participation' stamp: 'btr
11/22/2006 15:16'!
newStandAlone
^ ToolBuilder open: self new! !
!SMLoaderPlus class methodsFor: 'instance creation' stamp: 'btr 11/23/2006
11:13'!
open
"Create and open a SqueakMap Loader."
"SMLoaderPlus open"
^ (Smalltalk at: #ToolBuilder) open: self new! !
!SMLoaderPlus class methodsFor: 'class initialization' stamp: 'btr 11/30/2006
21:50'!
openMenuString
^ 'SqueakMap Catalog'! !
!SMLoaderPlus class methodsFor: 'instance creation' stamp: 'btr 11/23/2006
11:21'!
openOn: aSqueakMap
"Create and open a SqueakMap Loader on a given map."
"self openOn: SqueakMap default"
^ (Smalltalk at: #ToolBuilder) open: (self newOn: aSqueakMap)! !
!SMLoaderPlus class methodsFor: 'new-morph participation' stamp: 'btr
11/22/2006 15:18'!
prototypicalToolWindow
^ ToolBuilder open: self new; applyModelExtent; yourself! !
!SMLoaderPlus class methodsFor: 'new-morph participation' stamp: 'btr
11/22/2006 15:02'!
registerInFlapsRegistry
"Register the receiver in the system's flaps registry."
self environment
at: #Flaps
ifPresent: [:cl | (cl respondsTo: #registerQuad:forFlapNamed:)
ifTrue: [cl registerQuad: #(#SMLoader
#prototypicalToolWindow 'Package Loader' 'The SqueakMap Package Loader' )
forFlapNamed: 'Tools']]! !
!SMLoaderPlus class methodsFor: 'class initialization' stamp: 'btr 11/30/2006
21:50'!
unload
(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue:
[TheWorldMenu unregisterOpenCommand: self openMenuString].
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] ! !
!SMLoaderPlus class methodsFor: 'window color' stamp: 'btr 11/22/2006 15:02'!
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference."
^WindowColorSpec
classSymbol: self name
wording: 'Package Loader'
brightColor: Color yellow muchLighter duller
pastelColor: Color yellow veryMuchLighter duller
helpMessage: 'The SqueakMap Package Loader'! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 15:02'!
addFiltersToMenu: aMenu
| filterSymbol help |
self filterSpecs do: [:filterArray |
filterSymbol := filterArray second.
help := filterArray third.
aMenu addUpdating: #showFilterString: target: self selector:
#toggleFilterState: argumentList: (Array with: filterSymbol).
aMenu balloonTextForLastItem: help].
aMenu addLine;
addList: #(('Clear all filters' uncheckFilters 'Unchecks all
filters to list all packages'))
! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
addSelectedCategoryAsFilter
"Add a new filter that filters on the currently selected category.
Make it enabled as default."
categoriesToFilterIds add: self selectedCategory id! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 16:11'!
askToLoadUpdates
"Check how old the map is and ask to update it
if it is older than 10 days or if there is no map on disk."
| available |
available := map isCheckpointAvailable.
(available not or: [
(Date today subtractDate: (Date fromSeconds:
(map directory directoryEntryFor: map
lastCheckpointFilename)
modificationTime)) > 3])
ifTrue: [
(self confirm:
(available ifTrue: ['The map on disk is more
than 10 days old,
update it from the Internet?'] ifFalse: ['There is no map on disk,
fetch it from the Internet?']))
ifTrue: [self loadUpdates]]! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/1/2006 01:43'!
browseCacheDirectory
"Open a FileList2 on the directory for the package or release."
| item dir win |
item := self selectedPackageOrRelease
ifNil: [^ nil].
dir := item isPackage
ifTrue: [map cache directoryForPackage: item]
ifFalse: [map cache directoryForPackageRelease:
item].
win := FileList2 morphicViewOnDirectory: dir.
"withLabel: item name, ' cache directory'."
win openInWorld! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:56'!
buildButtonBarWith: aBuilder
^ aBuilder pluggablePanelSpec new
model: self;
layout: #horizontal;
children: (self commandSpecs select: [ :spec | spec fourth
includes: #all]
thenCollect: [ :spec |
aBuilder pluggableActionButtonSpec new
model: self;
label: spec first;
action: spec second;
help: spec third;
enabled: ((spec fourth
includes: #item) ifTrue: [#hasSelectedItem]);
yourself]);
name: #buttonBar;
yourself! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/22/2006 15:02'!
buildButtonNamed: labelText helpText: balloon action: action
| btn |
btn := PluggableButtonMorph on: self getState: nil action: action.
btn color: Color transparent;
hResizing: #shrinkWrap;
vResizing: #spaceFill;
label: labelText;
setBalloonText: balloon;
onColor: Color transparent offColor: Color transparent.
^ btn! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:56'!
buildCategoriesListWith: aBuilder
"Create the hierarchical list holding the category tree."
^ aBuilder pluggableTreeSpec new model: self;
roots: #categoryList;
getSelectedPath: #selectedCategoryPath;
getChildren: #categoryChildren:;
hasChildren: #categoryHasChildren:;
setSelected: #selectedCategory:;
menu: #categoriesMenu:;
label: #categoryLabel:;
autoDeselect: true;
wantsDrop: true;
name: #categoriesList;
yourself! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:57'!
buildPackagePaneWith: aBuilder
"Create the text area to the right in the loader."
^ aBuilder pluggableTextSpec new model: self; getText:
#itemDescription; name: #packagePane; yourself! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:57'!
buildPackagesListWith: aBuilder
"Create the hierarchical list holding the packages and releases."
^ aBuilder pluggableTreeSpec new model: self;
roots: #packageList;
getSelectedPath: #selectedItemPath;
setSelected: #selectedItem:;
menu: #packagesMenu:;
label: #itemLabel:;
getChildren: #itemChildren:;
hasChildren: #itemHasChildren:;
autoDeselect: true;
wantsDrop: true;
name: #packagesList;
yourself! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:57'!
buildSearchPaneWith: aBuilder
^ aBuilder pluggableInputFieldSpec new model: self;
selection: #searchSelection;
getText: #searchText; setText: #findPackage:notifying:; name:
#search; yourself! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 06:54'!
buildWith: aBuilder
"Create the package loader window."
| buttonBarHeight vertDivide horizDivide |
buttonBarHeight := 0.07.
vertDivide := 0.6.
horizDivide := 0.3.
builder := aBuilder.
window := builder build: (builder pluggableWindowSpec new model: self;
label: #label;
children: (OrderedCollection new
add: ((self buildButtonBarWith:
builder)
frame: (0 @ 0 corner: 1
@ buttonBarHeight));
add: ((self
buildSearchPaneWith: builder)
frame: (0 @
buttonBarHeight corner: horizDivide @ (buttonBarHeight * 2)));
add: ((self
buildPackagesListWith: builder)
frame: (0 @
(buttonBarHeight * 2) corner: horizDivide @ vertDivide));
add: ((self
buildCategoriesListWith: builder)
frame: (0 @ vertDivide
corner: horizDivide @ 1));
add: ((self
buildPackagePaneWith: builder)
frame:
(horizDivide @ buttonBarHeight corner: 1 @ 1));
yourself);
yourself).
window on: #mouseEnter send: #paneTransition: to: window.
window on: #mouseLeave send: #paneTransition: to: window.
window extent: self initialExtent.
^ window! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 12/1/2006 01:38'!
cachePackageReleaseAndOfferToCopy
"Cache package release, then offer to copy it somewhere.
Answer the chosen file's location after copy,
or the cache location if no directory was chosen."
| release installer newDir newName newFile oldFile oldName |
release := self selectedPackageOrRelease.
release isPackageRelease ifFalse: [ self error: 'Should be a package
release!!'].
installer := SMInstaller forPackageRelease: release.
[UIManager default informUser: 'Caching ' , release asString during:
[installer cache]] on: Error do: [:ex |
| msg |
msg := ex messageText ifNil: [ex asString].
self informException: ex msg: ('Error occurred during
download:\', msg, '\') withCRs.
^nil ].
installer isCached ifFalse: [self inform: 'Download failed, see
transcript for details'. ^nil].
oldName := installer fullFileName.
newDir := FileList2 modalFolderSelector: installer directory.
newDir ifNil: [ ^oldName ].
newDir = installer directory ifTrue: [ ^oldName ].
newName := newDir fullNameFor: installer fileName.
newFile := FileStream newFileNamed: newName.
newFile ifNil: [ ^oldName ].
newFile binary.
oldFile := FileStream readOnlyFileNamed: oldName.
oldFile ifNil: [ ^nil ].
oldFile binary.
[[ newDir copyFile: oldFile toFile: newFile ] ensure: [ oldFile close.
newFile close ]] on: Error do: [ :ex | ^oldName ].
^newName! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 15:02'!
categoriesMenu: aMenu
"Answer the categories-list menu."
self selectedCategory
ifNotNil: [aMenu addList: self categorySpecificOptions;
addLine].
aMenu addList: self generalOptions.
self addFiltersToMenu: aMenu.
^aMenu! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/24/2006 14:44'!
categoryChildren: aCategory
^ aCategory subCategories! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/24/2006 14:45'!
categoryHasChildren: aCategory
^ aCategory hasSubCategories! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/24/2006 14:46'!
categoryLabel: aCategory
^ aCategory name! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 11/30/2006 21:01'!
categoryList
"Create the category list for the hierarchical list.
We sort the categories by name but ensure that 'Squeak versions'
is first if it exists."
| list first |
list := (map categories
select: [:each | each parent isNil]) asArray
sort: [:c1 :c2 | c1 name <= c2 name].
first := list
detect: [:any | any name = 'Squeak versions']
ifNone: [].
first
ifNotNil: [list := list copyWithout: first.
list := {first} , list].
^ list! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 15:02'!
categorySpecificOptions
| choices |
choices := OrderedCollection new.
(categoriesToFilterIds includes: self selectedCategory id)
ifTrue: [
choices add: #('Remove filter'
#removeSelectedCategoryAsFilter 'Remove the filter for the selected category.')]
ifFalse: [
choices add: #('Add as filter'
#addSelectedCategoryAsFilter 'Add the selection as a filter to hide unrelated
packages.')].
categoriesToFilterIds isEmpty ifFalse: [
choices add: #('Remove all filters' #removeCategoryFilters
'Remove all category filters.')].
^ choices! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 11/22/2006 15:02'!
changeFilters: anObject
"Update my selection."
| oldItem index |
oldItem := self selectedPackageOrRelease.
filters := anObject.
self packagesListIndex: ((index := self packageList indexOf: oldItem)
ifNil: [0]
ifNotNil: [index]).
self noteChanged! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 18:01'!
commandSpecFor: selector
^ self commandSpecs detect: [:spec | spec second = selector]! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 18:00'!
commandSpecs
^ #(('Install' installPackageRelease 'Install the latest version from
the server.' (item all))
('Email' emailPackageMaintainers 'Open an editor to send an
email to the owner and co-maintainers of this package.' (item all))
('Browse cache' browseCacheDirectory 'Browse cache directory of
the selection.' (item all))
('Copy from cache' cachePackageReleaseAndOfferToCopy 'Download
selected release into cache first if needed, and then offer to copy it
somewhere else.' (item))
('Force download into cache' downloadPackageRelease 'Force a
download of the selected release into the cache.' (item))
('Update' loadUpdates 'Update the package index from the
servers.' (all))
('Upgrade All' upgradeInstalledPackagesConfirm 'Upgrade all
installed packages (conf8irming each).' (all))
('Upgrade all installed packages'
upgradeInstalledPackagesNoConfirm '' (item))
('Upgrade all installed packages confirming each'
upgradeInstalledPackagesConfirm '' (item))
('Copy list' listInPasteBuffer 'Puts the list as text into the
clipboard.' (all))
('Save filters' saveFiltersAsDefault 'Saves the current filters
as default.' (all))
('Help' help 'What is this?' (all)))! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/22/2006 15:02'!
defaultButtonPaneHeight
"Answer the user's preferred default height for new button panes."
^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 01:50'!
defaultLabel
^ 'SqueakMap Package Loader'! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 12/1/2006 01:38'!
downloadPackageRelease
"Force a download of the selected package release into the cache."
| release |
release := self selectedPackageOrRelease.
release isPackageRelease ifFalse: [ self error: 'Should be a package
release!!'].
[UIManager default informUser: 'Downloading ' , release asString
during: [
(SMInstaller forPackageRelease: release) download]
] on: Error do: [:ex |
| msg |
msg := ex messageText ifNil: [ex asString].
self informException: ex msg: ('Error occurred during
download:\', msg, '\') withCRs]! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
emailPackageMaintainers
"Send mail to package owner and co-maintainers."
| item package toAddresses |
item := self selectedPackageOrRelease ifNil: [^ nil].
package := item isPackageRelease ifTrue: [item package] ifFalse: [item].
"(this logic should be moved to MailMessage as soon as it can handle
multiple To: addresses)"
toAddresses := '<', package owner email, '>'.
package maintainers ifNotNil: [
package maintainers do: [:maintainer |
toAddresses := toAddresses, ', <', maintainer email,
'>']].
SMUtilities sendMailTo: toAddresses regardingPackageRelease: item! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
filterAdd: anObject
self changeFilters: (self filters copyWith: anObject)
! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 11/22/2006 15:02'!
filterAutoInstall
^[:package | package isInstallable]! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 12/1/2006 01:42'!
filterAvailable
^[:package | package isAvailable]! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 11/22/2006 15:02'!
filterInstalled
^[:package | package isInstalled]! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 11/22/2006 15:02'!
filterNotInstalledYet
^[:package | package isInstalled not]! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 12/1/2006 01:42'!
filterNotUptoDate
^[:package | package isAvailable]! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 11/22/2006 15:02'!
filterPublished
^[:package | package isPublished]! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
filterRemove: anObject
self changeFilters: (self filters copyWithout: anObject)
! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 12/1/2006 01:43'!
filterSafelyAvailable
^[:package | package isSafelyAvailable]! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/30/2006 21:07'!
filterSpecs
"Return a specification for the filter menu. Is called each time."
| specs |
specs := #(#('Auto-installable packages' #filterAutoInstall 'display
only packages that can be installed automatically') #('New available packages'
#filterAvailable 'display only packages that are not installed or that have
newer releases available.') #('New safely-available packages'
#filterSafelyAvailable 'display only packages that are not installed or that
have newer releases available that are safe to install, meaning that they are
published and meant for the current version of Squeak.') #('Installed packages'
#filterInstalled 'Display only packages that are installed.') #('Published
packages' #filterPublished 'Display only packages that have at least one
published release.') ) asOrderedCollection.
categoriesToFilterIds
do: [:catId | specs add: {'Packages in ' , (map object: catId)
name. catId. 'Display only packages that are in the category.'}].
^ specs! !
!SMLoaderPlus methodsFor: 'filters' stamp: 'btr 12/1/2006 01:43'!
filterVersion
"Ignore spaces in the version string, they're sometimes spurious.
Not used anymore."
^[:package | package categories anySatisfy:
[:cat | (cat name, '*') match: (Smalltalk version copyWithout:
$ ) ]]! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
filters
^filters! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/24/2006 13:49'!
findPackage: aString notifying: aView
"Search and select a package with the given (sub) string in the name or
description. "
| index list match descriptions |
match := aString asString asLowercase.
index := self packagesListIndex.
list := self packageNameList.
list isEmpty
ifTrue: [^ self].
descriptions := self packageList collect: [:e | e description].
index + 1
to: list size
do: [:i | (((list at: i)
includesSubstring: match
caseSensitive: false)
or: [(descriptions at: i)
includesSubstring: match
caseSensitive: false])
ifTrue: [^ self packagesListIndex: i]].
"wrap around"
1
to: index
do: [:i | (((list at: i)
includesSubstring: match
caseSensitive: false)
or: [(descriptions at: i)
includesSubstring: match
caseSensitive: false])
ifTrue: [^ self packagesListIndex: i]].
self inform: 'No package matching ' , aString asString! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 15:02'!
generalOptions
^#( #('Upgrade all installed packages'
upgradeInstalledPackagesNoConfirm)
#('Upgrade all installed packages confirming each'
upgradeInstalledPackagesConfirm)
#('Put list in paste buffer' listInPasteBuffer)
#('Save filters as default' saveFiltersAsDefault)
#- )
! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 11/22/2006 18:36'!
hasSelectedItem
^ self selectedPackageOrRelease notNil! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/1/2006 01:44'!
help
"Present help text. If there is a web server available, offer to open
it.
Use the WebBrowser registry if possible, or Scamper if available."
| message browserClass |
message := 'Welcome to the SqueakMap package loader.
The names of packages are followed by versions: (installed -> latest).
If there is no arrow, your installed version of the package is the latest.
Bold packages and releases have been installed.
The checkbox menu items modify which packages you''ll see.
Take a look at them - only some packages are shown initially.
The options available for a package depend on how it was packaged.
Comment on a package by emailing the author or the squeak list.'.
browserClass := Smalltalk at: #WebBrowser ifPresent: [ :registry |
registry default ].
browserClass := browserClass ifNil: [ Smalltalk at: #Scamper ifAbsent:
[ ^self inform: message ]].
(self confirm: message, '
Would you like to view more detailed help on the SqueakMap swiki page?')
ifTrue: [ browserClass openOnUrl: 'http://wiki.squeak.org/2726' asUrl]!
!
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 11/22/2006 15:02'!
informException: ex msg: msg
"Tell the user that an error has occurred.
Offer to open debug notifier."
(self confirm: msg, 'Would you like to open a debugger?')
ifTrue: [ex pass]! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/5/2006 05:28'!
initialExtent
^500@400! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
installPackageRelease
"Install selected package or release.
The cache is used."
| item release |
item := self selectedPackageOrRelease ifNil: [^ nil].
item isPackageRelease
ifTrue: [
(item isPublished or: [self confirm: 'Selected release
is not published yet, install anyway?'])
ifTrue: [^self installPackageRelease: item]]
ifFalse: [
release := item
lastPublishedReleaseForCurrentSystemVersion.
release ifNil: [
(self confirm: 'The package has no published
release for your Squeak version, try releases for any Squeak version?')
ifTrue: [
release := item
lastPublishedRelease.
release ifNil: [
(self confirm: 'The
package has no published release at all, take the latest of the unpublished
releases?')
ifTrue:
[release := item lastRelease]]]].
release ifNotNil: [^self installPackageRelease:
release]]! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 12/1/2006 01:53'!
installPackageRelease: aRelease
"Install a package release. The cache is used."
| myRelease installer |
aRelease isCompatibleWithCurrentSystemVersion ifFalse:
[(self confirm:
'The package you are about to install is not listed as
being compatible with your image version (', SystemVersion current
majorMinorVersion, '),
so the package may not work properly.
Do you still want to proceed with the install?')
ifFalse: [^ self]].
myRelease := self installedReleaseOfMe.
installer := SMInstaller forPackageRelease: aRelease.
[UIManager default informUser: 'Downloading ' , aRelease asString
during:
[installer download].
UIManager default informUser: 'Installing ' , aRelease asString during:
[
installer install.
myRelease = self installedReleaseOfMe
ifFalse: [self reOpen]
ifTrue: [self noteChanged]]
] on: Error do: [:ex |
| msg |
msg := ex messageText ifNil:[ex asString].
self informException: ex msg: ('Error occurred during
install:\', msg, '\') withCRs].! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 11/22/2006 15:02'!
installedReleaseOfMe
"Return the release of the installed package loader."
^SMSqueakMap default installedReleaseOf: (SMSqueakMap default
packageWithId: '941c0108-4039-4071-9863-a8d7d2b3d4a3').! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/24/2006 14:44'!
itemChildren: anItem
^ anItem isPackage
ifTrue: [anItem releases]
ifFalse: [#()]! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 11/22/2006 19:56'!
itemDescription
^ self selectedPackageOrRelease
ifNil: ['<No package selected>']
ifNotNilDo: [:item | item fullDescription]! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/24/2006 14:45'!
itemHasChildren: anItem
^ anItem isPackage and: [anItem releases notEmpty]! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/1/2006 01:44'!
itemLabel: anItem
| label |
label := anItem isPackage
ifTrue: [anItem name
, (anItem versionLabel
ifEmpty: ['']
ifNotEmptyDo:
[:lbl | ' (' , anItem versionLabel , ')'])]
ifFalse: [anItem smartVersion].
^ anItem isInstalled
ifTrue: [label asText allBold]
ifFalse: [label]! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 11/24/2006 17:17'!
label
^ self
labelForShown: (packagesList
ifNil: [self packageList])! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
labelForFilter: aFilterSymbol
^(self filterSpecs detect: [:fs | fs second = aFilterSymbol]) first! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 01:50'!
labelForShown: packagesShown
"Update the label of the window."
^ self defaultLabel , ' (',
(packagesShown size < map packages size ifTrue: [packagesShown
size printString,
' shown out of '] ifFalse: ['']) , map packages size
printString, ' packages)'! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
listInPasteBuffer
"Useful when talking with people etc.
Uses the map to produce a nice String."
Clipboard clipboardText:
(String streamContents: [:s |
packagesList do: [:p |
s nextPutAll: p nameWithVersionLabel; cr ]])
asText! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 12/1/2006 01:31'!
loadUpdates
[UIManager default informUser: 'Loading Updates' during: [
map loadUpdates.
self noteChanged ]
] on: Error do: [:ex |
self informException: ex msg: ('Error occurred when updating
map:\', ex messageText, '\') withCRs]! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 11/24/2006 14:05'!
noteChanged
filters
ifNil: [^ self reOpen].
map
ifNotNil: [packagesList := nil.
selectedCategory := nil.
self changed: #categoryList.
self changed: #packageList.
self changed: #packagesListIndex.
"update my selection"
self contentsChanged]! !
!SMLoaderPlus methodsFor: 'initialization' stamp: 'btr 11/22/2006 16:11'!
on: aSqueakMap
"Initialize instance."
map := aSqueakMap.
map synchWithDisk.
filters := DefaultFilters copy.
categoriesToFilterIds := DefaultCategoriesToFilterIds copy.
self askToLoadUpdates! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
package: aPackage filteredByCategory: aCategory
"Answer true if the package should be shown
if we filter on <aCategory>. It should be shown
if itself or any of its releases has the category."
| releases |
releases := aPackage releases.
^(aPackage hasCategoryOrSubCategoryOf: aCategory) or: [
releases anySatisfy: [:rel |
rel hasCategoryOrSubCategoryOf: aCategory]]! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 01:49'!
packageList
"Return a list of the SMPackages that should be visible
by applying all the filters. Also filter based on the currently
selected category - if any."
| list |
list := packagesList ifNil: [packagesList := self
packageListCalculated].
selectedCategory ifNotNil: [
list := list select: [:each | self package: each
filteredByCategory: selectedCategory]].
self updateLabel: list.
^ list! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 01:49'!
packageListCalculated
"Return a list of the SMPackages that should be visible
by applying all the filters. Also filter based on the currently
selected category - if any."
^ self packages select: [:p |
filters allSatisfy: [:currFilter |
currFilter isSymbol
ifTrue: [(self perform: currFilter) value: p]
ifFalse: [self package: p filteredByCategory:
(map object: currFilter)]]]! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 01:50'!
packageNameList
^ self packageList collect: [:e | e name]! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 18:30'!
packageSpecificOptions
| choices packageOrRelease |
packageOrRelease := self selectedPackageOrRelease.
choices := OrderedCollection new.
packageOrRelease isInstallable ifTrue: [
choices add: (self commandSpecFor: #installPackageRelease)].
(packageOrRelease isDownloadable and: [packageOrRelease isCached])
ifTrue: [
choices add: (self commandSpecFor: #browseCacheDirectory)].
(packageOrRelease isPackageRelease and: [packageOrRelease
isDownloadable]) ifTrue: [
choices add: (self commandSpecFor:
#cachePackageReleaseAndOfferToCopy).
choices add: (self commandSpecFor: #downloadPackageRelease)].
choices add: (self commandSpecFor: #emailPackageMaintainers).
^ choices! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 11/22/2006 16:11'!
packages
"We request the packages as sorted by name by default."
^map packagesByName asArray
! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 11/24/2006 14:01'!
packagesListIndex
^ self packageList indexOf: self selectedItem! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 11/24/2006 14:01'!
packagesListIndex: anObject
self
selectedItem: (anObject = 0
ifFalse: [self packageList at: anObject])! !
!SMLoaderPlus methodsFor: 'menus' stamp: 'btr 11/22/2006 15:02'!
packagesMenu: aMenu
"Answer the packages-list menu."
self selectedPackageOrRelease
ifNotNil: [aMenu addList: self packageSpecificOptions; addLine].
aMenu addList: self generalOptions.
self addFiltersToMenu: aMenu.
^aMenu! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 12/1/2006 01:45'!
perform: selector orSendTo: otherTarget
"Selector was just chosen from a menu by a user. If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."
^ (self respondsTo: selector)
ifTrue: [self perform: selector]
ifFalse: [super perform: selector orSendTo: otherTarget]! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 11/26/2006 23:22'!
reOpen
"Close this package loader, probably because it has been updated,
and open a new one."
self inform: 'This package loader has been upgraded and will be closed
and reopened to avoid strange side effects.'.
window delete.
(Smalltalk at: self class name) open! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
removeCategoryFilters
"Remove all category filters."
categoriesToFilterIds := OrderedCollection new! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
removeSelectedCategoryAsFilter
"Remove the filter that filters on the currently selected category."
categoriesToFilterIds remove: self selectedCategory id! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
saveFiltersAsDefault
"Save the current filters as default so that they
are selected the next time the loader is opened."
DefaultFilters := filters copy.
DefaultCategoriesToFilterIds := categoriesToFilterIds copy! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/24/2006 14:35'!
searchSelection
"Selects all of the default search text so that a type-in overwrites
it."
^ {1. self searchText size}! !
!SMLoaderPlus methodsFor: 'interface' stamp: 'btr 11/24/2006 14:35'!
searchText
"A dummy default search text so that the field describes its purpose."
^ 'Search packages'! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 11/24/2006 14:02'!
selectedCategory
"Return selected category."
^ selectedCategory! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 16:37'!
selectedCategory: anSMCategory
"Change the selected category."
selectedCategory := anSMCategory.
selectedCategory
ifNotNil: [(selectedCategory objects includes: self
selectedItem)
ifFalse: [self selectedItem: nil]].
self changed: #selectedCategory.
self changed: #packageList! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 11/24/2006 14:52'!
selectedCategoryPath
"Return selected category's path."
| path |
path := #().
selectedCategory
ifNotNil: [selectedCategory parent
ifNotNilDo: [:p | path := path copyWith: p].
path := path copyWith: selectedCategory].
^ path
collect: [:cat | self categoryLabel: cat]! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 11/24/2006 14:02'!
selectedItem
^ selectedItem! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 16:27'!
selectedItem: anItem
"This == workaround protects us from recursion since ToolBuilder's tree
widgets will always tell us that the selection has been updated when we tell it
that the selection path has been updated. Cleaner solutions invited."
anItem == selectedItem ifFalse: [
selectedItem := anItem.
self changed: #selectedItemPath.
self changed: #itemDescription.
self changed: #hasSelectedItem]! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 12/1/2006 16:16'!
selectedItemPath
| path |
path := #().
(selectedItem isKindOf: SMPackageRelease)
ifTrue: [path := path copyWith: selectedItem package].
selectedItem
ifNotNil: [path := path copyWith: selectedItem].
^ path! !
!SMLoaderPlus methodsFor: 'accessing' stamp: 'btr 11/24/2006 14:03'!
selectedPackageOrRelease
"Return selected package or package release."
^ selectedItem! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
showFilterString: aFilterSymbol
^(self stateForFilter: aFilterSymbol), (self labelForFilter:
aFilterSymbol)! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
stateForFilter: aFilterSymbol
^(self filters includes: aFilterSymbol) ifTrue: ['<yes>'] ifFalse:
['<no>']
! !
!SMLoaderPlus methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 15:02'!
toggleFilterState: aFilterSymbol
^(self filters includes: (aFilterSymbol))
ifTrue: [self filterRemove: aFilterSymbol]
ifFalse: [self filterAdd: aFilterSymbol]! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
uncheckFilters
"Uncheck all filters."
filters := OrderedCollection new.
self noteChanged! !
!SMLoaderPlus methodsFor: 'lists' stamp: 'btr 12/1/2006 01:50'!
updateLabel: packagesShown
"Update the label of the window."
window ifNotNilDo: [:w | w setLabel: (self labelForShown:
packagesShown)]! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 12/1/2006 01:29'!
upgradeInstalledPackages
"Tries to upgrade all installed packages to the latest published
release for this
version of Squeak. So this is a conservative approach."
| installed old myRelease toUpgrade info |
installed := map installedPackages.
old := map oldPackages.
old isEmpty ifTrue: [
^self inform: 'All ', installed size printString, '
installed packages are up to date.'].
toUpgrade := map upgradeableAndOldPackages.
toUpgrade isEmpty ifTrue: [
^self inform: 'None of the ', old size printString, '
old packages of the ', installed size printString, ' installed can be
automatically upgraded. You need to upgrade them manually.'].
info := old size < toUpgrade size ifTrue: [
'Of the ', old size printString, ' old packages only ',
toUpgrade size printString, ' can be upgraded.
The following packages will not be upgraded:
', (String streamContents: [:s | (old removeAll: toUpgrade; yourself)
do: [:p | s nextPutAll: p nameWithVersionLabel; cr]])]
ifFalse: ['All old packages upgradeable.'].
(self confirm: info, '
About to upgrade the following packages:
', (String streamContents: [:s | toUpgrade do: [:p | s nextPutAll: p
nameWithVersionLabel; cr]]), 'Proceed?') ifTrue: [
myRelease := self installedReleaseOfMe.
[UIManager default informUser: 'Upgrading Installed
Packages' during: [
map upgradeOldPackages.
self inform: toUpgrade size printString, '
packages successfully upgraded.'.
myRelease = self installedReleaseOfMe
ifFalse: [self reOpen]
ifTrue: [self noteChanged]]
] on: Error do: [:ex |
self informException: ex msg: ('Error occurred
when upgrading old packages:\', ex messageText, '\') withCRs]]! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
upgradeInstalledPackagesConfirm
"Tries to upgrade all installed packages to the latest published
release for this
version of Squeak. Confirms on each upgrade."
^ self upgradeInstalledPackagesConfirm: true! !
!SMLoaderPlus methodsFor: 'private' stamp: 'btr 12/1/2006 01:29'!
upgradeInstalledPackagesConfirm: confirmEach
"Tries to upgrade all installed packages to the latest published
release for
this version of Squeak. If confirmEach is true we ask for every
upgrade. "
| installed old myRelease toUpgrade info |
installed := map installedPackages.
old := map oldPackages.
old isEmpty
ifTrue: [^ self inform: 'All ' , installed size printString , '
installed packages are up to date.'].
toUpgrade := map upgradeableAndOldPackages.
toUpgrade isEmpty
ifTrue: [^ self inform: 'None of the ' , old size printString ,
' old packages of the ' , installed size printString , ' installed can be
automatically upgraded. You need to upgrade them manually.'].
info := old size < toUpgrade size
ifTrue: ['Of the ' , old size printString , ' old packages only
' , toUpgrade size printString , ' can be upgraded.
The following packages will not be upgraded:
'
, (String
streamContents:
[:s | (old removeAll: toUpgrade;
yourself)
do: [:p | s nextPutAll: p nameWithVersionLabel;
cr]])]
ifFalse: ['All old packages upgradeable.'].
(self confirm: info , '
About to upgrade the following packages:
'
, (String
streamContents: [:s | toUpgrade
do: [:p | s
nextPutAll: p nameWithVersionLabel;
cr]]) , 'Proceed?')
ifTrue: [myRelease := self installedReleaseOfMe.
[UIManager default informUser: 'Upgrading Installed
Packages' during:
[confirmEach
ifTrue: [map
upgradeOldPackagesConfirmBlock: [:p | self confirm: 'Upgrade ' , p
installedRelease packageNameWithVersion , ' to ' , (p
lastPublishedReleaseForCurrentSystemVersionNewerThan: p installedRelease)
listName , '?']]
ifFalse: [map
upgradeOldPackages].
self inform: toUpgrade size printString
, ' packages successfully processed.'.
myRelease = self installedReleaseOfMe
ifTrue: [self noteChanged]
ifFalse: [self reOpen]]]
on: Error
do: [:ex | self informException: ex msg:
('Error occurred when upgrading old packages:\' , ex messageText , '\')
withCRs]]! !
!SMLoaderPlus methodsFor: 'actions' stamp: 'btr 11/22/2006 15:02'!
upgradeInstalledPackagesNoConfirm
"Tries to upgrade all installed packages to the latest published
release for this
version of Squeak. No confirmation on each upgrade."
^ self upgradeInstalledPackagesConfirm: false! !
!SMPackageWrapper methodsFor: 'comparing' stamp: 'dvf 9/21/2003 16:25' prior:
27998626!
= anObject
^self withoutListWrapper = anObject withoutListWrapper! !
!SMPackageWrapper methodsFor: 'converting' stamp: 'btr 11/22/2006 00:54' prior:
27998778!
asString
| string |
string := item name, ' (', item versionLabel, ')'.
item isInstalled ifTrue: [string := string asText allBold].
"(string includesSubString: '->') ifTrue: [string := string asText
color: Color green]."
^ string! !
!SMPackageWrapper methodsFor: 'accessing' stamp: 'dvf 10/14/2003 18:58' prior:
27998902!
contents
^item releases reversed collect: [:e | SMPackageReleaseWrapper with:
e]! !
!SMPackageWrapper methodsFor: 'testing' stamp: 'dvf 9/21/2003 16:25' prior:
27999070!
hash
^self withoutListWrapper hash! !
!SMPackageWrapper methodsFor: 'accessing' stamp: 'btr 11/22/2006 16:55'!
help
^ 'This shows all packages with their releases that should be displayed
according the current filter.'! !
!SMPackageWrapper methodsFor: 'accessing' stamp: 'btr 11/22/2006 16:49'!
label
^ self asString! !
!SMPackageWrapper methodsFor: 'printing' stamp: 'dvf 9/21/2003 16:22' prior:
27999192!
printOn: aStream
aStream nextPutAll: 'wrapper for: ', item printString! !
!SMCategoryWrapper methodsFor: 'comparing' stamp: 'ar 2/9/2004 02:13' prior:
27849043!
= anObject
^self withoutListWrapper = anObject withoutListWrapper! !
!SMCategoryWrapper methodsFor: 'converting' stamp: 'btr 11/30/2006 18:53'
prior: 27849195!
asString
^ item name , ' (' , self numberOfObjects printString , ')'! !
!SMCategoryWrapper methodsFor: 'accessing' stamp: 'ar 2/9/2004 02:35' prior:
27849301!
category
^item! !
!SMCategoryWrapper methodsFor: 'accessing' stamp: 'btr 11/30/2006 21:02' prior:
27849402!
contents
^ item subCategories
collect: [:n | self class with: n model: n]! !
!SMCategoryWrapper methodsFor: 'model access' stamp: 'btr 11/30/2006 21:02'!
getList
^ Array
with: (self class with: self contents model: model)! !
!SMCategoryWrapper methodsFor: 'testing' stamp: 'btr 11/30/2006 18:53'!
hasContents
^ item hasSubCategories! !
!SMCategoryWrapper methodsFor: 'comparing' stamp: 'ar 2/9/2004 02:13' prior:
27849700!
hash
^self withoutListWrapper hash! !
!SMCategoryWrapper methodsFor: 'accessing' stamp: 'btr 11/22/2006 16:56'!
help
^ 'The categories are structured in a tree. Packages and package
releases belong to several categories. You can add one or more categories as
filters and enable them in the menu.'! !
!SMCategoryWrapper methodsFor: 'accessing' stamp: 'BJP 11/22/2002 14:17'!
model
^model! !
!SMCategoryWrapper methodsFor: 'accessing' stamp: 'btr 11/30/2006 18:53'!
numberOfObjects
" | total |
total _ 0.
model allCategoriesDo: [:c |
total _ total + c objects size].
^total"
^item objects size! !
!SMPackageReleaseWrapper methodsFor: 'converting' stamp: 'btr 11/30/2006 21:30'
prior: 27997393!
asString
"Show installed releases with a trailing asterisk."
| string |
string := item smartVersion.
"Older SMBase versions don't have isInstalled.'"
(item respondsTo: #isInstalled) ifTrue:
[item isInstalled ifTrue: [string := (string , ' *') asText
allBold]].
^ string! !
!SMPackageReleaseWrapper methodsFor: 'accessing' stamp: 'btr 11/22/2006 17:14'!
contents
^ #()! !
!SMPackageReleaseWrapper methodsFor: 'accessing' stamp: 'btr 11/22/2006 16:49'!
label
^ self asString
! !
!SMLoader class methodsFor: 'class initialization' stamp: 'btr 12/1/2006 15:47'
prior: 27944626!
initialize
"Hook us up in the world menu."
"self initialize"
Smalltalk
at: #ToolBuilder
ifAbsent: [self registerInFlapsRegistry.
(Preferences windowColorFor: #SMLoader) = Color white
ifTrue: ["not set"
Preferences
setWindowColorFor: #SMLoader
to: (Color colorFrom: self
windowColorSpecification brightColor)].
(TheWorldMenu respondsTo: #registerOpenCommand:)
ifTrue: [| oldCmds |
oldCmds := TheWorldMenu registry
select: [:cmd | cmd first includesSubString: 'Package Loader'].
oldCmds do: [:cmd | TheWorldMenu
unregisterOpenCommand: cmd first].
TheWorldMenu registerOpenCommand: {self
openMenuString. {self. #open}}]].
DefaultFilters := OrderedCollection new.
DefaultCategoriesToFilterIds := OrderedCollection new! !
!SMLoader class methodsFor: 'class initialization' stamp: 'btr 11/30/2006
21:52'!
openMenuString
^ 'SqueakMap Catalog'! !
!SMLoader class methodsFor: 'class initialization' stamp: 'btr 11/30/2006
21:52' prior: 27945298!
unload
(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue:
[TheWorldMenu unregisterOpenCommand: self openMenuString].
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] ! !
!SMLoader methodsFor: 'menus' stamp: 'btr 11/21/2006 16:08' prior: 54331069!
addFiltersToMenu: aMenu
| filterSymbol help |
self filterSpecs do: [:filterArray |
filterSymbol := filterArray second.
help := filterArray third.
aMenu addUpdating: #showFilterString: target: self selector:
#toggleFilterState: argumentList: (Array with: filterSymbol).
aMenu balloonTextForLastItem: help].
aMenu addLine;
addList: #(('Clear all filters' uncheckFilters 'Unchecks all
filters to list all packages'))
! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/22/2006 01:15' prior: 27927912!
browseCacheDirectory
"Open a FileList2 on the directory for the package or release."
| item dir win |
item := self selectedPackageOrRelease ifNil: [^ nil].
item ifNil: [^nil].
dir := item isPackage
ifTrue: [model cache directoryForPackage: item]
ifFalse: [model cache
directoryForPackageRelease: item].
win := FileList2 morphicViewOnDirectory: dir. " withLabel: item name, '
cache directory'."
win openInWorld
! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/22/2006 14:52'!
buildButtonBar
| aRow btn |
aRow := AlignmentMorph newRow beSticky.
aRow color: Color transparent;
clipSubmorphs: true.
self buttonSpecs do: [:spec |
btn := self buildButtonNamed: spec first helpText: spec third
action: spec second.
aRow addMorphBack: btn]
separatedBy: [aRow addTransparentSpacerOfSize: 3@0].
^ aRow! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/22/2006 01:27'!
buildButtonNamed: labelText helpText: balloon action: action
| btn |
btn := PluggableButtonMorph on: self getState: nil action: action.
btn color: Color transparent;
hResizing: #shrinkWrap;
vResizing: #spaceFill;
label: labelText;
setBalloonText: balloon;
onColor: Color transparent offColor: Color transparent.
^ btn! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/30/2006 19:04' prior: 27928394!
buildMorphicCategoriesList
"Create the hierarchical list holding the category tree."
| list |
list := (SimpleHierarchicalListMorph
on: self
list: #categoryWrapperList
selected: #selectedCategoryWrapper
changeSelected: #selectedCategoryWrapper:
menu: #categoriesMenu:
keystroke: nil) autoDeselect: true;
enableDrag: false;
enableDrop: true;
yourself.
list setBalloonText: 'The categories are structured in a tree. Packages
and package releases belong to several categories.
You can add one or more categories as filters and enable them in the menu.'.
"list scroller submorphs do:[:each| list expandAll: each]."
list adjustSubmorphPositions.
^ list! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/22/2006 00:22' prior: 27929139!
buildMorphicPackagesList
"Create the hierarchical list holding the packages and releases."
^(SimpleHierarchicalListMorph
on: self
list: #packageWrapperList
selected: #selectedItemWrapper
changeSelected: #selectedItemWrapper:
menu: #packagesMenu:
keystroke: nil)
autoDeselect: false;
enableDrag: false;
enableDrop: true;
setBalloonText: 'This shows all packages with their releases
that should be displayed according the current filter.';
yourself! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/30/2006 21:13'!
buildPackageButtonBar
| aRow |
"Somewhat patterned after IRCe's buttonRow method."
aRow := AlignmentMorph newRow beSticky.
aRow color: Color transparent;
clipSubmorphs: true.
^ aRow! !
!SMLoader methodsFor: 'interface' stamp: 'gk 5/5/2006 02:05' prior: 27929686!
buildPackagePane
"Create the text area to the right in the loader."
| ptm |
ptm := PluggableTextMorph
on: self
text: #contents
accept: nil
readSelection: nil "#packageSelection "
menu: nil.
ptm setBalloonText: 'This is where the selected package or package
release is displayed.'.
ptm lock.
^ptm! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/30/2006 21:08' prior: 27930070!
buildSearchPane
"Cribbed from MessageNames>>inMorphicWindowWithInitialSearchString:"
| typeInView searchButton typeInPane |
typeInView := PluggableTextMorph
on: self
text: nil
accept: #findPackage:notifying:
readSelection: nil
menu: nil.
typeInView acceptOnCR: true;
vResizing: #spaceFill;
hResizing: #spaceFill;
setTextMorphToSelectAllOnMouseEnter;
askBeforeDiscardingEdits: false;
setProperty: #alwaysAccept toValue: true.
(typeInView respondsTo: #hideScrollBarsIndefinitely)
ifTrue: [typeInView hideScrollBarsIndefinitely]
ifFalse: [typeInView hideScrollBarIndefinitely].
searchButton := SimpleButtonMorph new target: typeInView;
color: Color white;
label: 'Search';
actionSelector: #accept;
arguments: #(); yourself.
typeInPane := AlignmentMorph newRow.
typeInPane vResizing: #shrinkWrap;
hResizing: #shrinkWrap;
listDirection: #leftToRight;
addMorphFront: searchButton;
addTransparentSpacerOfSize: 6 @ 0;
addMorphBack: typeInView;
setBalloonText: 'Type into the pane, then press Search (or hit
RETURN) to visit the next package matching what you typed.'.
^ typeInPane! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/22/2006 14:24'!
buttonSpecs
^ #(('Install' installPackageRelease 'Install the latest version from
the server.')
('Email' emailPackageMaintainers 'Open an editor to send an
email to the owner and co-maintainers of this package.')
('Browse cache' browseCacheDirectory 'Browse cache directory of
the selection.')
('Update' loadUpdates 'Update the package index from the
servers.')
('Upgrade All' upgradeInstalledPackagesConfirm 'Upgrade all
installed packages (confirming each).')
('Help' help 'What is this?'))! !
!SMLoader methodsFor: 'menus' stamp: 'btr 11/21/2006 16:11' prior: 27936393!
categorySpecificOptions
| choices |
choices := OrderedCollection new.
(categoriesToFilterIds includes: self selectedCategory id)
ifTrue: [
choices add: #('Remove filter'
#removeSelectedCategoryAsFilter 'Remove the filter for the selected category.')]
ifFalse: [
choices add: #('Add as filter'
#addSelectedCategoryAsFilter 'Add the selection as a filter to hide unrelated
packages.')].
categoriesToFilterIds isEmpty ifFalse: [
choices add: #('Remove all filters' #removeCategoryFilters
'Remove all category filters.')].
^ choices! !
!SMLoader methodsFor: 'lists' stamp: 'btr 11/30/2006 21:01' prior: 27933585!
categoryWrapperList
"Create the wrapper list for the hierarchical list.
We sort the categories by name but ensure that 'Squeak versions'
is first if it exists."
| list first |
list := (model categories
select: [:each | each parent isNil]) asArray
sort: [:c1 :c2 | c1 name <= c2 name].
first := list
detect: [:any | any name = 'Squeak versions']
ifNone: [].
first
ifNotNil: [list := list copyWithout: first.
list := {first} , list].
^ list
collect: [:cat | SMCategoryWrapper with: cat model: self]! !
!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:45' prior:
27913226!
changeFilters: anObject
"Update my selection."
| oldItem index |
oldItem := self selectedPackageOrRelease.
filters := anObject.
self packagesListIndex: ((index := self packageList indexOf: oldItem)
ifNil: [0]
ifNotNil: [index]).
self noteChanged! !
!SMLoader methodsFor: 'interface' stamp: 'btr 11/30/2006 17:30' prior: 27930584!
createWindow
| buttonBarHeight searchHeight vertDivide horizDivide |
buttonBarHeight := 0.07.
searchHeight := 0.07.
vertDivide := 0.3.
horizDivide := 0.6.
self addMorph: (self buildButtonBar borderWidth: 0)
frame: (0.0 @ 0.0 corner: 1.0 @ buttonBarHeight).
self addMorph: (self buildSearchPane borderWidth: 0)
frame: (0.0 @ buttonBarHeight corner: vertDivide @
searchHeight).
self addMorph: (self buildMorphicPackagesList borderWidth: 0)
frame: (0.0 @ (buttonBarHeight + searchHeight) corner:
vertDivide @ horizDivide).
self addMorph: (self buildMorphicCategoriesList borderWidth: 0)
frame: (0.0 @ horizDivide corner: vertDivide @ 1.0).
self addMorph: (self buildPackagePane borderWidth: 0)
frame: (vertDivide @ buttonBarHeight corner: 1.0 @ 1.0).
self on: #mouseEnter send: #paneTransition: to: self.
self on: #mouseLeave send: #paneTransition: to: self! !
!SMLoader methodsFor: 'interface' stamp: 'gk 7/12/2004 11:14' prior: 27931214!
defaultButtonPaneHeight
"Answer the user's preferred default height for new button panes."
^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! !
!SMLoader methodsFor: 'interface' stamp: 'btr 12/1/2006 02:01'!
defaultLabel
^'SqueakMap Package Loader'! !
!SMLoader methodsFor: 'actions' stamp: 'btr 11/22/2006 01:14' prior: 27917579!
emailPackageMaintainers
"Send mail to package owner and co-maintainers."
| item package toAddresses |
item := self selectedPackageOrRelease ifNil: [^ nil].
package := item isPackageRelease ifTrue: [item package] ifFalse: [item].
"(this logic should be moved to MailMessage as soon as it can handle
multiple To: addresses)"
toAddresses := '<', package owner email, '>'.
package maintainers ifNotNil: [
package maintainers do: [:maintainer |
toAddresses := toAddresses, ', <', maintainer email,
'>']].
SMUtilities sendMailTo: toAddresses regardingPackageRelease: item! !
!SMLoader methodsFor: 'filter utilities' stamp: 'btr 11/22/2006 00:14' prior:
27923782!
filterSpecs
"Return a specification for the filter menu. Is called each time."
| specs |
specs := #(
#('Auto-installable packages' #filterAutoInstall 'display only packages
that can be installed automatically')
#('New available packages' #filterAvailable 'display only packages that
are not installed or that have newer releases available.')
#('New safely-available packages' #filterSafelyAvailable 'display only
packages that are not installed or that have newer releases available that are
safe to install, meaning that they are published and meant for the current
version of Squeak.')
_______________________________________________
pypy-commit mailing list
[email protected]
https://mail.python.org/mailman/listinfo/pypy-commit
