!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: classorganizer.gs,v 1.13 2008-01-09 22:50:09 stever Exp $
!
! Superclass Hierarchy:
!   ClassOrganizer, Object.
!
!=========================================================================

expectvalue %String
run

  Object _newKernelSubclass: 'ClassOrganizer'
    instVarNames: #(#classes #classNames #user #hierarchy #categories
                    #rootClass)
    classVars: #()
    classInstVars: #()
    poolDictionaries: #[]
    inDictionary: Globals
    constraints: #()
    instancesInvariant: false
    isModifiable: false
    reservedOop: 729
%

removeallmethods ClassOrganizer
removeallclassmethods ClassOrganizer

category: 'For Documentation Installation only'
classmethod: ClassOrganizer
installDocumentation

| doc txt |
doc := GsClassDocumentation newForClass: self.

txt := (GsDocText new) details:
'A ClassOrganizer collects classes from the current user''s symbol list
 and organizes them into searchable tables that allow tools to present
 the classes and to perform cross-referencing and fileout.

 An organizer can also be created to work with a subtree of another
 organizer''s hierarchy.  Such organizers do not track categorization
 of classes but only the subtree of the overall hierarchy.'.
doc documentClassWith: txt.

txt := (GsDocText new) details:
'A ClassSet of all the classes found by an instance.'.
doc documentInstVar: #classes with: txt.

txt := (GsDocText new) details:
'Class name information.'.
doc documentInstVar: #classNames with: txt.

txt := (GsDocText new) details:
'Reserved for future use.'.
doc documentInstVar: #user with: txt.

txt := (GsDocText new) details:
'An IdentityDictionary of class->subclasses associations.'.
doc documentInstVar: #hierarchy with: txt.

txt := (GsDocText new) details:
'A Dictionary of category->classes associations.'.
doc documentInstVar: #categories with: txt.

txt := (GsDocText new) details:
'The root class of the instance.'.
doc documentInstVar: #rootClass with: txt.

self description: doc.
%

! ------------------- Class methods for ClassOrganizer
category: 'Instance Creation'
classmethod: ClassOrganizer
new

"Creates and returns a new instance of ClassOrganizer with a root of Object."

| inst |

inst := (super new) rootClass: Object.
inst updateClassInfo.
^inst
%

category: 'Instance Creation'
classmethod: ClassOrganizer
newWithRoot: aClass from: anotherOrganizer

"Creates a new ClassOrganizer that is limited to the given subtree of objects."

| inst |
inst := super new.
inst rootClass: aClass.
inst classes: ClassSet new.
inst classes add: aClass.
inst classes addAll: (anotherOrganizer allSubclassesOf: aClass).
inst rebuildHierarchy.
^inst
%

! ------------------- Instance methods for ClassOrganizer
category: 'Private - Class Collection'
method: ClassOrganizer
addCachedClassNames

"Adds new class names to the auto-complete set.  New class names are cached
 until the auto-completer is needed, then they are all merged in to the
 completer in one shot.  Users that don't make use of auto-completion features
 never have to pay the price of updating the completer's structures."

| completer cache |
completer := classNames at: 1.
cache := classNames at: 2.
1 to: cache size do: [:i |
  completer addString: (cache at: i).
].
classNames at: 2 put: nil
%

category: 'Updating'
method: ClassOrganizer
addClass: cls

"Adds the class cls, replacing any existing class with the same superclass."

| nm superClass cat old matching |

hierarchy == nil ifTrue: [^self].
nm := cls name.
superClass := cls superClass.
superClass == nil ifTrue:[ ^ self "subclasses of nil not supported, bug13156"].

(hierarchy includesKey: superClass) ifTrue: [
  hierarchy at: superClass put:
    ((hierarchy at: superClass) select: [:e |
        e name ~= nm]).
  (hierarchy at: superClass) add: cls.
]
ifFalse: [
  hierarchy at: superClass put: (ClassSet new add: cls; yourself)
].

matching := classes select: {:each | each.name = nm}.
matching size > 0 ifTrue: [
  classes := classes - matching
].
classes add: cls.

cat := categories at: cls category otherwise: nil.
cat == nil ifTrue: [
  categories at: cls category put: #[cls].
]
ifFalse: [
  nm := cls name.
  [old := cat findFirst: [:x | x name = nm].
    old > 0] whileTrue: [
    cat removeFrom: old to: old
  ].
  cat add: cls
].

self addedClassName: nm
%

category: 'Private - Class Collection'
method: ClassOrganizer
addedClassName: name

"Adds the new class name to the auto-complete set."

(classNames at: 2) == nil ifTrue: [
  classNames at: 2 put: Array new.
].
(classNames at: 2) add: name.
%

category: 'Reporting'
method: ClassOrganizer
allReferencesTo: selector

"Returns an Array of two Arrays.  The first contains GsMethods that
 implement, send, or refer to the given selector.  The second contains the
 indexes into sourceStrings where the first reference takes place."

^self allReferencesTo: selector in: classes
%

category: 'Reporting'
method: ClassOrganizer
allReferencesTo: aSelector in: classSet

"Returns an Array of two Arrays.  The first contains GsMethods that
 implement, send, or refer to the given selector.  The second contains the
 indexes into sourceStrings where the first reference takes place."

| methods indices cset cls methodDict selectorSym |

methods := Array new.
indices := Array new.
selectorSym := Symbol _existingWithAll: aSelector .
selectorSym == nil ifTrue:[ ^#[methods, indices] ].

"Sort the class set by name, then search"
cset := classSet sortAscending.
1 to: cset size do: [ :i |
  1 to: 2 do: [ :n | 
    cls := (n == 1 ifTrue: [cset at: i] ifFalse: [cls class]).
    methodDict := cls _methodDict.
    methodDict valuesDo: [ :method | | srcOffset |
      "Check for implementors first"
      method _selector == selectorSym ifTrue: [
	methods add: method.
	indices add: 1.
      ]
      ifFalse: [
	"Check for senders"
        srcOffset := method _sourceOffsetOfFirstSendOf: selectorSym .
        srcOffset ~~ nil ifTrue:[
          methods add: method .
          indices add: srcOffset.
        ]
	ifFalse: [ | sz |
	  "Check for references"
	  sz := method size.
	  sz > 0 ifTrue: [ | lit k |
            k := method literalsOffset .
            [k <= sz _and: [ lit := method at: k.
              (lit == selectorSym _or:
                [ (lit isKindOf: SymbolAssociation) _and:
                  [lit key == selectorSym] ] ) not ]
            ] whileTrue: [
              k := k + 1
            ].

            k <= sz ifTrue: [
              methods add: method.
              indices add: (method _sourceString findString: selectorSym
                                                 startingAt: 1).
            ].
          ].
        ].
      ].
    ].
  ].
].

^#[methods, indices]
%

category: 'Queries'
method: ClassOrganizer
allSubclassesOf: aClass

"Returns a collection of all the subclasses of the given class: an Array that
 holds a depth-first traversal of the class hierarchy subtree rooted at
 aClass."

| result subs |

classes == nil ifTrue: [
  self updateClassInfo
].
(classes includesIdentical: aClass) ifFalse: [
  self addClass: aClass.
  ^self allSubclassesOf: aClass
].

result := Array new.
subs := hierarchy at: aClass otherwise: nil.
subs size > 0 ifTrue: [
  subs := subs sortAscending.
  subs do: [:each |
    result add: each; addAll: (self allSubclassesOf: each)
  ].
].
^result
%

category: 'Accessing'
method: ClassOrganizer
categories

"Returns the value of the instance variable 'categories'."

^categories
%

category: 'Queries'
method: ClassOrganizer
categoryCrossReference

"Returns a dictionary of all method categories and the classes with methods
 in each category."

| resultDict cls |

resultDict := SymbolDictionary new.
1 to: classes size do: [ :i |
  1 to: 2 do: [ :which |
    cls := classes _at: i.
    which == 2 ifTrue: [ cls := cls class ].
    cls _categories keysAndValuesDo: [ :aKey :selectorSet | | clsset |
       clsset := resultDict at: aKey otherwise: nil.
       clsset == nil ifTrue: [
	 clsset := #[].
	 resultDict at: aKey put: clsset.
         ].
      clsset add: cls.
      ].
    ].
  ].
^resultDict
%

category: 'Reports'
method: ClassOrganizer
categoryCrossReferenceByName

"Returns a String containing a report from a cross-reference of method
 categories."

^self categoryCrossReferenceReportByName: nil
%

category: 'Private'
method: ClassOrganizer
categoryCrossReferenceReportByName: catsDict

"Returns a String containing a report from a cross-reference of categories.
 The argument may be nil or a dictionary similar to the one that
 categoryCrossReference returns."

| dict report cats cat clsset |

(dict := catsDict) == nil ifTrue: [
  dict := self categoryCrossReference
].

report := String new.
cats := SortedCollection withAll: dict keys.
1 to: cats size do: [ :i |
  cat := cats at: i.
  report add: cat; add: Character tab.
  clsset := dict at: cat.
  1 to: clsset size do: [ :j |
    report add: (clsset at: j) name.
    j < clsset size ifTrue: [ report add: $, ].
  ].

  report lf.
].

^report.
%

category: 'Accessing'
method: ClassOrganizer
classCompletion

"Returns the AutoComplete holding the class names."

(classNames at: 2) ~~ nil ifTrue: [
  self addCachedClassNames
].
^(classNames at: 1).
%

category: 'Accessing'
method: ClassOrganizer
classNames

"Returns the Array of class names held by the receiver."

(classNames at: 2) ~~ nil ifTrue: [
  self addCachedClassNames
].
^(classNames at: 1) strings.
%

category: 'Accessing'
method: ClassOrganizer
classes

"Returns the ClassSet of classes held by the receiver."

^classes
%

category: 'Updating'
method: ClassOrganizer
classes: aClassSet

"Updates the set of classes held by the receiver.  The receiver's
 hierarchy should be rebuilt after this (see rebuildHierarchy)."

classes := aClassSet
%

category: 'Private - Class Collection'
method: ClassOrganizer
collectClassNames

"Causes the receiver to collect all of the names of classes from the
 current collection of classes and form an auto-completer for the names."

| set |

set := Array new.
1 to: classes size do:
  [ :i | set add: (classes _at: i) name ].

classNames := #[ AutoComplete new strings: set cluster: false , nil ].
%

category: 'Private'
method: ClassOrganizer
symbolList

"Returns the symbol list of the current user."

^ System myUserProfile symbolList copy
%

category: 'Private'
method: ClassOrganizer
dictionaryAndSymbolOf: anObject

^ System myUserProfile dictionaryAndSymbolOf: anObject
%

category: 'Private - Class Collection'
method: ClassOrganizer
collectClasses

"Rebuilds the class hierarchy structure.  This message should be sent whenever
 new classes have been created or imported from other users."

<primitive: 901> "enter protected mode to be able to modify symbol list"

| allClasses symlist dict rootIsObj done |

allClasses := ClassSet new.

" make a list of all the named classes "

symlist := self symbolList copy.
rootIsObj := rootClass == Object.
done := IdentitySet new.

[symlist size > 0] whileTrue: [
  dict := symlist at: 1.
  (done includesIdentical: dict) ifFalse: [
    dict valuesDo: [:aValue | | anObj |
      anObj:= aValue.
      anObj isBehavior ifTrue: [
        anObj isMeta ifTrue: [ anObj := anObj thisClass ].
	(rootIsObj _or: [anObj isSubclassOf: rootClass]) ifTrue: [
	  allClasses add: anObj
        ].
      ].
    ].
    done add: dict.
  ].
  symlist protectedRemoveFrom: 1 to: 1.
].

System _disableProtectedMode.
classes := allClasses.
%

category: 'Fileout Aids'
method: ClassOrganizer
determineClassFileoutOrder: classdict

"Returns an ordered collection of the values that are classes in classdict,
 specifying the order of fileout.  The argument should be a SymbolDictionary."

| org order classSet block |

( classdict isEmpty _or:
[ nil == (classdict detectAssociations: [ :assoc | assoc value isBehavior ] ifNone: [ nil ]) ])
  ifTrue: [ ^ Array new ].

"form a hierarchy for the set of classes"
org := Dictionary new.
org at: #nil put: ClassSet new.

classSet := ClassSet new.
classdict associationsDo: [:assn | | sub |
  sub := assn value.
  sub isBehavior ifTrue: [ | superCls |
    classSet add: sub.
    [superCls := sub superClass.  superCls ~~ nil] whileTrue: [ | assoc |
      assoc := org associationAt: superCls otherwise: nil.
      assoc == nil ifTrue: [
        assoc := Association newWithKey: superCls value: ClassSet new.
          org add: assoc
      ].
      assoc value add: sub.
      sub := superCls
    ].
    (org at: #nil) add: sub.
  ].
].

"make a recursive block to order the subclass sets and weed out unwanted 
 classes"
order := Array new.
block := [:order:subs |
  1 to: subs size do: [:i | | assoc class |
    class := subs at: i.
    (classSet includesIdentical: class) ifTrue: [
      order add: class
    ].
    assoc := org associationAt: class otherwise: nil.
    (assoc ~~ nil _and: [assoc value size > 0]) ifTrue: [
      block value: order value: (assoc value sortAscending)
    ]
  ]
].

block value: order value: ((org at: #nil) sortAscending).
^order
%

category: 'Fileout Aids'
method: ClassOrganizer
fileOutClassesAndMethodsInDictionary: aSymbolDictionary on: aStream

"Files out all source code for classes in aSymbolDictionary in Topaz filein
 format on aStream."

| order |
order := self determineClassFileoutOrder: aSymbolDictionary.
self fileOutClasses: order on: aStream inDictionary: aSymbolDictionary
     named: (aSymbolDictionary name).
self fileOutMethods: aSymbolDictionary order: order on: aStream
%

category: 'Fileout Aids'
method: ClassOrganizer
fileOutClasses: order on: stream inDictionary: dict named: dictName

"Writes out code on the given stream that creates the given classes in the
 dictionary with the given name.  The dict argument should be a SymbolDictionary
 of classes."

| class str lf head term any nm |

order size == 0 ifTrue: [ ^self ].

head := 'doit
'.
term := '
' , '%
'.

lf := Character lf.

"Determine the dictionary name to use"
nm := dictName.

1 to: order size do: [:j |
  class := order at: j.
  class fileOutPreClassOn: stream.
  stream nextPutAll: head;
          nextPutAll:
    (class _modifiableDefinitionInDictionary: dict named: nm );
    nextPut: $.;
    nextPutAll: term
].

"now write out constraints and make non-modifiable classdict non-modifiable "
1 to: order size do: [:k |
  class := order at: k.
  any := false.
  str := class _constraintCreationExpressionIn: dict.
  str size > 0 ifTrue: [
    stream nextPutAll: head.
    stream nextPutAll: (dict keyAtValue: class); nextPut: $ ;
      nextPutAll: str;
      nextPut: $.; nextPut: lf.
    any := true.
  ].
  class isModifiable ifFalse: [
    any ifFalse: [
      stream nextPutAll: head.
      any := true
    ].
    stream nextPutAll: (dict keyAtValue: class); nextPutAll: ' immediateInvariant.'.
  ].
  any ifTrue: [
    stream nextPutAll: term
  ]
].
%

category: 'Private'
method: ClassOrganizer
addTempDictionary: classdict

System myUserProfile symbolList insertObject: classdict at: 1
%

category: 'Private'
method: ClassOrganizer
removeTempDictionary: classdict

System myUserProfile symbolList remove: classdict
%

category: 'Fileout Aids'
method: ClassOrganizer
fileOutMethods: classdict order: order on: stream

"File out each class's code and embedded classes."

| class |
classdict size == 0 ifTrue: [ ^self ].
"put the class dictionary in the temporary symbol list so it will be used for
  name resolution during method fileout"
self addTempDictionary: classdict.
1 to: order size do: [:l |
  class := order at: l.
  class fileOutCategoriesOn: stream.
].
self removeTempDictionary: classdict.
%

category: 'Fileout Aids'
method: ClassOrganizer
fileOutOtherMethods: methodInfo on: stream

"Files out a set of methods on the given stream/file.  methodInfo must be an
 Array of pairs: #(class selector)."

| pair |
1 to: methodInfo size do: [:i |
  pair := methodInfo at: i.
  "use the fileOutMethod: version here so the category will be included"
  stream nextPutAll: ((pair at: 1) fileOutMethod: (pair at: 2)).
].
%

category: 'Accessing'
method: ClassOrganizer
hierarchy

"Returns the value of the instance variable 'hierarchy'."

^hierarchy
%

category: 'Reporting'
method: ClassOrganizer
implementorsOf: aSelector

"Returns a collection of GsMethods that implement the given selector."

^self implementorsOf: aSelector in: classes
%

category: 'Reporting'
method: ClassOrganizer
implementorsOf: aSelector in: aclassSet

"Returns a collection of GsMethods that implement the given selector."

| result cset cls gsMethod |

result := Array new.
cset := aclassSet sortAscending.
1 to: cset size do:
  [ :j |
  cls := cset at: j.
  gsMethod := cls _methodDict at: aSelector otherwise: nil .
  gsMethod ~~ nil ifTrue: [ result add: gsMethod ].
  
  gsMethod := cls class _methodDict at: aSelector otherwise: nil .
  gsMethod ~~ nil ifTrue: [ result add: gsMethod ].
  ].

^result
%

category: 'Private - Class Collection'
method: ClassOrganizer
rebuildCategories

""

| cls arr cat |

   "gemstone64,  changed categories from a SymbolDictionary 
    to a StringKeyValueDictionary to avoid unnecessary symbol creation"

categories := StringKeyValueDictionary new.
1 to: classes size do: [:i |
  cls := classes _at: i.
  cat := cls category.
  arr := categories at: cat otherwise: nil.
  arr == nil ifTrue: [
    arr := #[].
    categories at: cat put: arr
  ].
  arr add: cls
].
%

category: 'Private - Class Collection'
method: ClassOrganizer
rebuildHierarchy

"Builds an IdentityDictionary containing all classes as keys and ClassSets of
 their subclasses as values.  As a side-effect, the classes collection is
 expanded to include any superclasses that aren't in the user's name space."

| hier supers each sup supsup c |

hier := IdentityDictionary new.
supers := ClassSet new.

"add each class to its superclass's subclass set"
1 to: classes size do: [:i |
  each := classes _at: i.
  sup := each superClass.
  sup ~~ nil ifTrue: [
    (classes includesIdentical: sup) ifFalse: [
      "keep track of superclasses that aren't in the class set and complete
        their hierarchies on a second pass"
      supsup := sup.
      [ supsup ~~ nil ] whileTrue: [
        (supsup ~~ sup) ifFalse: [
          supers add: supsup
        ].
        supsup == rootClass ifTrue: [ supsup := nil ] ifFalse: [ supsup := supsup superClass ]
      ]
    ].
    (c := hier at: sup otherwise: nil) == nil ifTrue: [
      c := ClassSet new.
      hier at: sup put: c.
    ].
    c add: each
  ].
].

"get rid of superclasses that have already been processed"
supers := supers - classes.

"complete the class hierarchies for superclasses that weren't in the
  initial set of classes"
1 to: supers size do: [:i |
  each := supers _at: i.
  sup := each superClass.
  sup ~~ nil ifTrue: [
    (c := hier at: sup otherwise: nil) == nil ifTrue: [
      c := ClassSet new.
      hier at: sup put: c.
    ].
    c add: each
  ].
].

classes := classes + supers.
hierarchy := hier
%

category: 'Updating'
method: ClassOrganizer
recategorize: class to: newCategory

"Move the class from its present category to the given category."

| oldcat oldlist newlist idx |
oldcat := class category.
class category: newCategory.
oldlist := categories at: oldcat otherwise: nil.
oldlist ~~ nil ifTrue: [
  idx := oldlist indexOf: class.
  idx > 0 ifTrue: [
    oldlist removeFrom: idx to: idx
  ]
].
newlist := categories at: newCategory otherwise: nil.
newlist == nil ifTrue: [
  categories at: newCategory put: #[class]
]
ifFalse: [
  newlist add: class
]
%

! _recompileWithSubclasses:newClass:  removed per bug 8052 .
!  this method sends messages that are not yet implemented in the server image
! 
! category: 'Schema Modification'
! method: ClassOrganizer
! _recompileWithSubclasses: oldClass newClass: newClass
! 
! "Copies information and methods from oldClass to newClass, replaces
!  oldClass with newClass in the organizer's structures, then does the same for
!  all of the subclasses of oldClass.  Returns an Array containing two
!  Arrays and a Boolean:
! 
!  1) the old classes
!  2) the corresponding new classes
!  3) whether or not all compilations were successful
! 
!  A browser on the methods that failed to recompile is opened to allow the user
!  to fix the problems.  The organizer is updated to contain the newly created
!  classes."
! 
! | cls oclass failedMethods failedStream failedText assn
!   oclasses nclasses badclasses sidx x pos dict autoLock badLocks lblock |
! 
! badclasses := Array new.
! 
! failedStream := WriteStream on: Array new.
! 
! failedMethods := newClass _copyMethodsAndVariablesFrom: oldClass
!   except: nil dictionaries: self symbolList.
! self linkOldClass: oldClass toNewClass: newClass.
! failedMethods size > 0 ifTrue: [
!   badclasses add: oldClass.
!   failedStream nextPutAll: failedMethods.
! ].
! 
! (classes includesIdentical: oldClass) ifFalse: [
!   oclasses := #[]
! ]
! ifTrue: [
!   oclasses := self allSubclassesOf: oldClass.
! ].
! oclasses insertObject: oldClass at: 1.
! nclasses := Array with: newClass.
! oclasses size > 1 ifTrue: [
!   2 to: oclasses size do: [:i |
!     sidx := oclasses indexOf: (oclasses at: i) superClass.
!     pos := failedStream position.
!     nclasses add: (
!       (oclasses at: i)
!         copyClassWithSuperClass: (nclasses at: sidx)
!         errorsTo: failedStream).
!     dict := self dictionaryAndSymbolOf: (oclasses at: i).
!     autoLock ifTrue: [
!       assn := (dict at: 1) associationAt: (dict at: 2).
!       System writeLock: assn ifDenied: lblock ifChanged: lblock ifNotCommitted: [].
!     ].
!     dict == nil ifTrue: [
!       System myUserGlobals at: (nclasses at: i) name put: (nclasses at: i)
!     ]
!     ifFalse: [
!       (dict at: 1) at: (dict at: 2) put: (nclasses at: i)
!     ].
!     self linkOldClass: (oclasses at: i) toNewClass: (nclasses at: i).
!     pos ~= failedStream position ifTrue: [
!       badclasses add: (oclasses at: i)
!     ].
!   ].
! ].
! failedMethods := failedStream contents.
! 1 to: nclasses size do: [:i |
!   self addClass: (nclasses at: i).
! ].
! 
! "Show any error messages"
! badclasses size > 0 ifTrue: [
!   badclasses do: [:each |
!     each logModified: 'method dictionary (failed recompilation)'
!   ].
!   x := nil.
! 
!   "signal compilation errors"
! 
! ].
! 
! badLocks size > 0 ifTrue: [
!   "display a notifier"
! ].
! 
! ^#[oclasses, nclasses, badclasses size > 0]
! %

category: 'Reporting'
method: ClassOrganizer
referencesTo: aSymbol

"Returns an Array of two sequenceable collections.  The first contains
 GsMethods that refer to the given symbol, and the second contains
 corresponding indexes into sourceStrings where the first reference takes
 place."

^self referencesTo: aSymbol in: classes
%

category: 'Reporting'
method: ClassOrganizer
referencesTo: aSymbol in: aclassSet

"Returns an Array of two sequenceable collections.  The first contains
 GsMethods that reference the given symbol as a literal, 
 and the second contains corresponding indexes into sourceStrings where 
 the first such reference takes place."

| result resulti cset cls |

result := Array new.
resulti := Array new.

cset := aclassSet sortAscending.
1 to: cset size do: [ :i |
  cls := cset at: i.
  #[ cls _methodDict , cls class _methodDict ] do:[ :methodDict |
    methodDict valuesDo:[ :method | | sz |
      sz := method size.
      sz > 0 ifTrue: [ | lit k |
        k := method literalsOffset.

        [ k <= sz _and: [ lit := method at: k. 
	  ( lit == aSymbol _or: [ (lit isKindOf: SymbolAssociation) 
                            _and: [lit key == aSymbol] ]) not  ] ]
        whileTrue: [
          k := k + 1
        ].

        k <= sz ifTrue: [
	  result add: method.
          resulti add: (method _sourceString findString: aSymbol startingAt: 1)
        ].
      ].
    ].
   ].
  ].

^#[ result, resulti ]
%

category: 'Accessing'
method: ClassOrganizer
rootClass

"Returns the root class for this organizer."

^rootClass
%

category: 'Updating'
method: ClassOrganizer
rootClass: aClass

"Sets the root class of the receiver's hierarchy.  Not generally a useful
 thing to do."

rootClass := aClass
%

! fix bug 11544
category: 'Reporting'
method: ClassOrganizer
searchForCategory: catname in: classSet

"Returns a collection of GsMethods in the given category."

| result cset catSym |

result := Array new.
catname _validateByteClass: CharacterCollection.
catSym := Symbol _existingWithAll: catname .
catSym == nil ifTrue:[ ^ result ].
cset := classSet sortAscending.
1 to: cset size do: [ :j |
  #[cset at: j, (cset at: j) class] do: [ :cls | | cat mdict |
    cat := cls _categories at: catSym otherwise: nil.
    cat == nil ifFalse:[ 
      mdict := cls _methodDict.
      cat do: [ :selector | | method |
	method := mdict at: selector otherwise: nil.
	method == nil ifTrue: [
	  self notify: 'Missing method ' , selector quoted ,
		       ' in category ' , catSym , ' in class ' , cls name.
	]
	ifFalse: [
	  result add: method
	].
      ].
    ].
  ].
].

^result
%

category: 'Reporting'
method: ClassOrganizer
sendersOf: aSelector

"Returns an Array of two Arrays.  The first subarray contains GsMethods
 that send the given selector.  The second subarray contains indexes where the
 first use of the selector occurs within the sourceString of the method."

^self sendersOf: aSelector in: classes
%

category: 'Reporting'
method: ClassOrganizer
sendersOfReport: aSelector

"Returns a String describing the methods that are senders of the specified
 selector."

| sendersInfo senderMeths result LF |
sendersInfo := self sendersOf: aSelector .
senderMeths := sendersInfo at: 1 .
result := String new .
LF := Character lf .
1 to: senderMeths size do:[:j | | aMeth |
  aMeth := senderMeths at: j .
  result addAll: aMeth inClass name .
  result addAll: ' >> ' ; addAll: aMeth selector  ; add: LF .
  ].
^ result
%

category: 'Reporting'
method: ClassOrganizer
sendersOf: aSelector in: aclassSet

"Returns an Array of two Arrays.  The first subarray contains GsMethods
 that send the given selector.  The second subarray contains indexes where the
 first use of the selector occurs within the sourceString of the method."

| result resulti cset cls aSymbol |

result := Array new.
resulti := Array new.
aSymbol := Symbol _existingWithAll: aSelector .
aSymbol == nil ifTrue:[ ^#[ result, resulti ] ].

(aclassSet isKindOf: ClassSet) ifFalse: [
  cset := ClassSet withAll: aclassSet
]
ifTrue: [
  cset := aclassSet
].

cset := cset sortAscending.
1 to: cset size do: 
[ :i |
cls := cset at: i.
#[ cls _methodDict, cls class _methodDict ] do:[ :methodDict| 
  methodDict valuesDo:[ :gsMethod | | srcOffset |
    srcOffset := gsMethod _sourceOffsetOfFirstSendOf: aSymbol .
    srcOffset ~~ nil ifTrue:[
      result add: gsMethod .
      resulti add: srcOffset.
      ].
    ].
  ].
].

^#[result, resulti]
%

category: 'Modifying Classes'
method: ClassOrganizer
makeInstancesPersistent: aClass 

"Recursively make aClass and all subclasses persistable.

 If an error occurs, the session will be unable to commit and
 must logout/login before commits are allowed again."

<primitive: 901> 
aClass instancesNonPersistent ifTrue:[ | success |
  [ | subCs |
    success := false .
    aClass _makeInstancesPersistent .
    subCs := self subclassesOf: aClass .
    subCs do:[ :aSubcls |
      self makeInstancesPersistent: aSubcls .
    ].
    success := true .
  ] ensure:[
    success ifFalse:[ System _disallowCommitClassModFailure ].
  ]
].
System _disableProtectedMode.
%

category: 'Modifying Classes'
method: ClassOrganizer
makeInstancesNonPersistent: aClass 

"Recursively make aClass and all subclasses non-persistent.

 If an error occurs, the session will be unable to commit and
 must logout/login before commits are allowed again."

<primitive: 901> 
aClass instancesNonPersistent ifFalse:[ | success |
  [ | subCs |
    success := false .
    aClass _makeInstancesNonPersistent .
    subCs := self subclassesOf: aClass .
    subCs do:[ :aSubcls |
      self makeInstancesNonPersistent: aSubcls .
    ].
    success := true .
  ] ensure:[
    success ifFalse:[ System _disallowCommitClassModFailure ].
  ]
].
System _disableProtectedMode.
%

category: 'Queries'
method: ClassOrganizer
subclassesOf: aClass

"Returns a copy of the set of subclasses for the given class.
 Generates an error if the receiver does not hold the given class."

classes == nil ifTrue: [
  self updateClassInfo
].
(classes includesIdentical: aClass) ifFalse: [
  self addClass: aClass.
  (classes includesIdentical: aClass) ifFalse: [
    self addClass: aClass.
    ^self subclassesOf: aClass
  ].
].
^(hierarchy at: aClass ifAbsent: [ClassSet new]) copy
%

category: 'Reporting'
method: ClassOrganizer
substringSearch: aString

"Returns an Array of two Arrays.  The first subarray contains GsMethods
 whose sources include the given substring.  The second subarray contains
 indexes where the first occurrence of the substring was found."

^self substringSearch: aString in: classes
%

category: 'Reporting'
method: ClassOrganizer
substringSearch: aString in: aclassSet

"Returns an Array of two Arrays.  The first subarray contains GsMethods
 whose sources include the given substring.  The second subarray contains
 indexes where the first occurrence of the substring was found."

| result resulti list cls |

result := Array new.
resulti := Array new.
list := aclassSet sortAscending.
1 to: list size do: 
[ :i |
cls := list at: i.
#[ cls _methodDict, cls class _methodDict] do:[ :methodDict |
  methodDict valuesDo:[ :gsMethod | | index |
    index := gsMethod _sourceString findString: aString startingAt: 1.
    index > 0 ifTrue: [
      result add: gsMethod .
      resulti add: index
      ].
    ].
  ].
].

^#[result, resulti]
%

category: 'Class Collection'
method: ClassOrganizer
update

"Causes the receiver to rescan for classes and rebuild internal
 structures.  Synonymous with updateClassInfo."

self updateClassInfo
%

category: 'Class Collection'
method: ClassOrganizer
updateClassInfo

"Causes the receiver to rescan for classes and rebuild internal structures."

self collectClasses; "find all visible classes"
    rebuildHierarchy; "build the hierarchy, fleshing out class set too"
    collectClassNames; "pull out the names of the classes and form auto-complete set"
    rebuildCategories "build the class categories"
%

category: 'Reporting'
method: ClassOrganizer
hierarchyReport

"Returns a String that is a class hierarchy report for all classes
 known to the receiver."

| report |
report := String new .
self _hierarchyReportForClass: Object indent: String new report: report .
^ report
%

category: 'Reporting'
method: ClassOrganizer
referencesToObject: anObject

"Returns an Array of GsMethods that reference the given object
 (through a variable binding)"

^self referencesToObject: anObject in: classes
%

category: 'Reporting'
method: ClassOrganizer
referencesToObject: anObject in: aclassSet

"Returns an Array of GsMethods that reference the given object
 (through a variable binding)"

| result cset cls |

result := Array new.

cset := aclassSet sortAscending.
1 to: cset size do: [ :i |
  cls := cset at: i.
  #[ cls _methodDict , cls class _methodDict ] do:[ :methodDict |
    methodDict valuesDo:[ :method | | sz |
      sz := method size.
      sz > 0 ifTrue: [ | lit k |
        k := method literalsOffset.

        [ k <= sz _and: [ lit := method at: k. 
	  ( lit == anObject _or: [ (lit isKindOf: SymbolAssociation) 
                            _and: [lit value == anObject] ]) not  ] ]
        whileTrue: [ k := k + 1 ].

        k <= sz ifTrue: [ result add: method ]]]]].

^result
%

category: 'Private'
method: ClassOrganizer
_hierarchyReportForClass: aClass indent: indent report: report 

""

| subClsArray nextIndent |
report addAll: indent; add: aClass name ; add: Character lf .
subClsArray := 
  (hierarchy at: aClass ifAbsent:[ IdentitySet new ]) sortAscending: 'name' .
nextIndent := indent , '  ' .
subClsArray do:[ :aSubCls |
  self _hierarchyReportForClass: aSubCls indent: nextIndent report: report 
  ].
%

