1"======================================================================
2|
3|   Smalltalk GUI namespace browser
4|
5|
6 ======================================================================"
7
8"======================================================================
9|
10| Copyright 2002, 2003 Free Software Foundation, Inc.
11| Written by Paolo Bonzini.
12|
13| This file is part of GNU Smalltalk.
14|
15| GNU Smalltalk is free software; you can redistribute it and/or modify it
16| under the terms of the GNU General Public License as published by the Free
17| Software Foundation; either version 2, or (at your option) any later version.
18|
19| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
20| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
21| FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
22| details.
23|
24| You should have received a copy of the GNU General Public License along with
25| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
26| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
27|
28 ======================================================================
29"
30
31
32
33ClassHierarchyBrowser subclass: NamespaceBrowser [
34    | curNamespace byCategory namespacesMap namespaces categories |
35
36    <comment: nil>
37    <category: 'Graphics-Browser'>
38
39    byCategory [
40	"If categories are being viewed, return true"
41
42	<category: 'accessing'>
43	^byCategory
44    ]
45
46    byCategory: aBoolean [
47	"Change instance/class representation and record data state changes"
48
49	<category: 'accessing'>
50	byCategory = aBoolean ifTrue: [^self].
51	curNamespace := nil.
52	byCategory := aBoolean.
53	self updateNamespaceList
54    ]
55
56    namespaceList [
57	<category: 'accessing'>
58	^byCategory ifTrue: [categories] ifFalse: [namespaces]
59    ]
60
61    namespaceSelection: assoc [
62	<category: 'accessing'>
63	| name |
64	name := assoc value.
65	curNamespace := name isNil | byCategory
66		    ifTrue: [name]
67		    ifFalse: [namespacesMap at: name].
68	curClass := nil.
69	self updateClassList
70    ]
71
72    namespaceString [
73	"Return name of selected class indented by 'n' spaces, where 'n' is the number
74	 of class' superclasses"
75
76	<category: 'accessing'>
77	| spaces |
78	curNamespace isNil ifTrue: [^nil].
79	byCategory ifTrue: [^curNamespace].
80	spaces := String new: curNamespace allSuperspaces size.
81	spaces atAllPut: Character space.
82	^spaces , curNamespace name
83    ]
84
85    readCategories [
86	<category: 'accessing'>
87	categories := Set new.
88	Class allSubclassesDo:
89		[:each |
90		each isMetaclass ifTrue: [categories add: each instanceClass category]].
91	categories := categories asSortedCollection
92    ]
93
94    readNamespaces [
95	<category: 'accessing'>
96	| stack top indent namespace subspaces |
97	stack := OrderedCollection new.
98	namespacesMap := Dictionary new: 17.
99	namespaces := OrderedCollection new.
100	subspaces := {Smalltalk} , RootNamespace allInstances.
101
102	[subspaces isNil
103	    ifFalse:
104		[top := stack
105			    addLast: (subspaces asSortedCollection: [:a :b | a name <= b name])].
106	[top isEmpty] whileTrue:
107		[stack removeLast.
108		stack isEmpty ifTrue: [^self].
109		top := stack last].
110	namespace := top removeFirst.
111	subspaces := namespace subspaces.
112	indent := String new: stack size - 1 withAll: Character space.
113	namespacesMap at: indent , namespace name put: namespace.
114	namespaces add: indent , namespace name]
115		repeat
116    ]
117
118    addSubNamespace: listView [
119	<category: 'namespace list blue button menu'>
120	| newNamespace |
121	curNamespace isNil ifTrue: [^listView beep].
122	curNamespace isNamespace ifFalse: [^listView beep].
123	newNamespace := (Prompter message: 'Enter a new namespace' in: listView)
124		    response.
125	newNamespace = '' ifTrue: [^self].
126	curNamespace addSubspace: newNamespace asSymbol.
127	self updateNamespaceList
128    ]
129
130    blueButtonMenuForNamespaces: theView [
131	"Install popup for namespace list popup"
132
133	<category: 'namespace list blue button menu'>
134	^(PopupMenu new: theView label: 'Namespace')
135	    selectors: #(#('Namespaces' #namespaces: #theView) #('Categories' #categories: #theView) #() #('File out...' #fileOutNamespace: #theView) #('File into namespace' #fileIntoNamespace: #theView) #() #('Add namespace' #addSubNamespace: #theVIew) #('Rename...' #renameNamespace: #theView) #('Update' #updateNamespaceList))
136	    receiver: self
137	    argument: theView
138    ]
139
140    categories: namespaceList [
141	<category: 'namespace list blue button menu'>
142	namespaceList canChangeState ifFalse: [^self].
143	self byCategory: true
144    ]
145
146    fileIntoNamespace: listView [
147	"File in a file to a currently selected namespace"
148
149	<category: 'namespace list blue button menu'>
150	| oldCurrent className fileName stream |
151	curNamespace isNil ifTrue: [^listView beep].
152	fileName := Prompter
153		    openFileName: 'Which file do you want me to read?'
154		    default: '*.st'
155		    in: listView.
156	fileName isNil ifTrue: [^listView beep].
157	oldCurrent := Namespace current.
158	Namespace current: curNamespace.
159	FileStream fileIn: fileName.
160	Namespace current: oldCurrent
161    ]
162
163    fileoutName [
164	<category: 'namespace list blue button menu'>
165	byCategory ifTrue: [^curNamespace].
166	^((curNamespace nameIn: Smalltalk) asString)
167	    replaceAll: Character space with: $-;
168	    yourself
169    ]
170
171    fileOutNamespace: listView [
172	"File out a description of the currently selected namespace"
173
174	<category: 'namespace list blue button menu'>
175	| oldCurrent className fileName stream |
176	curNamespace isNil ifTrue: [^listView beep].
177	fileName := self fileoutDir , self fileoutName , '.st'.
178	fileName := Prompter
179		    saveFileName: 'File out namespace'
180		    default: fileName
181		    in: listView.
182	fileName isNil ifTrue: [^self].
183	stream := FileStream open: fileName mode: FileStream write.
184	byCategory
185	    ifFalse:
186		[curNamespace superspace isNil
187		    ifFalse:
188			[stream
189			    nextPutAll: (curNamespace superspace nameIn: Smalltalk);
190			    nextPutAll: ' addSubspace: #';
191			    nextPutAll: curNamespace name;
192			    nextPutAll: '!';
193			    nl;
194			    nextPutAll: 'Namespace current: ';
195			    nextPutAll: (curNamespace nameIn: Smalltalk);
196			    nextPutAll: '!';
197			    nl;
198			    nl]
199		    ifTrue:
200			[stream
201			    nextPutAll: 'Namespace current: (RootNamespace new: #';
202			    nextPutAll: (curNamespace nameIn: Smalltalk);
203			    nextPutAll: ')!';
204			    nl;
205			    nl].
206		oldCurrent := Namespace current.
207		Namespace current: curNamespace].
208	classList do:
209		[:each |
210		(each trimSeparators includes: $()
211		    ifFalse: [(shownClasses at: each) fileOutOn: stream]].
212	byCategory
213	    ifFalse:
214		[Namespace current: oldCurrent.
215		stream
216		    nextPutAll: 'Namespace current: Smalltalk!';
217		    nl].
218	stream close.
219	self setFileoutDirFromFile: fileName
220    ]
221
222    namespaces: namespaceList [
223	<category: 'namespace list blue button menu'>
224	namespaceList canChangeState ifFalse: [^self].
225	self byCategory: false
226    ]
227
228    renameNamespace: listView [
229	"Rename currently selected namespace"
230
231	<category: 'namespace list blue button menu'>
232	| methods oldName newName prompter oldAssoc referrer |
233	curNamespace isNil ifTrue: [^listView beep].
234	oldName := self namespaceString trimSeparators.
235
236	"Prompt user for new name"
237	prompter := Prompter message: 'Rename namespace: ' , curNamespace name
238		    in: listView.
239	prompter response = '' ifTrue: [^self].
240	self byCategory
241	    ifTrue:
242		[shownClasses do: [:each | each category: prompter response].
243		self updateNamespaceList.
244		^self].
245	oldName := oldName asSymbol.
246	newName := prompter response asSymbol.
247	(newName at: 1) isUppercase
248	    ifFalse: [^self error: 'Namespace name must begin with an uppercase letter'].
249	referrer := curNamespace superspace isNil
250		    ifTrue: [Smalltalk]
251		    ifFalse: [curNamespace superspace].
252	(referrer includesKey: newName)
253	    ifTrue: [^self error: newName , ' already exists'].
254
255	"Save old Association and remove namespace temporarily"
256	oldAssoc := referrer associationAt: oldName.
257	referrer removeKey: oldName.
258
259	"Rename the namespace now and re-add it"
260	curNamespace name: newName asSymbol.
261	referrer at: newName asSymbol put: curNamespace.
262
263	"Notify programmer of all references to renamed namespace"
264	methods := SortedCollection new.
265	CompiledMethod allInstancesDo:
266		[:method |
267		((method refersTo: oldAssoc) or: [method refersTo: oldAssoc key])
268		    ifTrue: [methods add: method]].
269	methods isEmpty
270	    ifFalse:
271		[ModalDialog new
272		    alertMessage: 'Rename all references to
273		    namespace ' , oldName
274			    , Character nl asSymbol , 'to the new name: '
275			    , newName
276		    in: listView.
277		MethodSetBrowser new
278		    openOn: methods
279		    title: 'References to ' , oldName
280		    selection: oldName].
281
282	"Update namespace list"
283	self updateNamespaceList
284    ]
285
286    topClasses [
287	<category: 'namespace list blue button menu'>
288	^self topMetas collect: [:each | each instanceClass]
289    ]
290
291    topMetas [
292	<category: 'namespace list blue button menu'>
293	curNamespace isNil ifTrue: [^#()].
294	^byCategory
295	    ifTrue: [Class allSubclasses select: [:each | each category = curNamespace]]
296	    ifFalse:
297		[Class allSubclasses select: [:each | each environment = curNamespace]]
298    ]
299
300    updateNamespaceList [
301	"Invoked from class list pane popup.  Update class list pane through the
302	 change/update mechanism"
303
304	<category: 'namespace list blue button menu'>
305	byCategory ifTrue: [self readCategories] ifFalse: [self readNamespaces].
306	self changeState: #namespaceList.
307	self updateClassList
308    ]
309
310    createNamespaceListIn: upper [
311	<category: 'initializing'>
312	| list |
313	upper addChildView: ((list := PList new: 'Namespaces' in: upper)
314		    initialize;
315		    data: self;
316		    stateChange: #namespaceList;
317		    changedSelection: #newNamespaceSelection;
318		    handleUserChange: #namespaceSelection:;
319		    listMsg: #namespaceList;
320		    selectionMsg: #namespaceString;
321		    menuInit: (self blueButtonMenuForNamespaces: list);
322		    yourself).
323	"Register three types of messages"
324	self layoutUpperPaneElement: list blox num: -1
325    ]
326
327    createUpperPanesIn: upper [
328	<category: 'initializing'>
329	self createNamespaceListIn: upper.
330	super createUpperPanesIn: upper
331    ]
332
333    createTopView [
334	<category: 'initializing'>
335	^BrowserShell new: 'Namespace Browser'
336    ]
337
338    initialize [
339	<category: 'initializing'>
340	self updateNamespaceList
341    ]
342
343    layoutUpperPaneElement: blox num: n [
344	<category: 'initializing'>
345	blox
346	    x: 150 * n + 150
347	    y: 0
348	    width: 150
349	    height: 200
350    ]
351
352    open [
353	<category: 'initializing'>
354	byCategory := false.
355	super open
356    ]
357
358    currentNamespace [
359	<category: 'overriding'>
360	^byCategory ifTrue: [Namespace current] ifFalse: [curNamespace]
361    ]
362]
363
364