!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: gspackagepolicy.gs,v 1.18.2.2 2008-02-20 22:48:18 dhenrich Exp $
!
! Superclass Hierarchy:
!   GsPackagePolicy, Object
!
!=========================================================================

! Fix 38326
expectvalue %String
doit
| oldClass expectedInstVars newClass |
expectedInstVars := #(#'enabled' #'homeSymbolDict' #'externalSymbolList' 
	#'authorInitials' #'sessionMethodDictionary').
oldClass := Globals at: #GsPackagePolicy otherwise: nil.
(oldClass notNil and: [oldClass instVarNames = expectedInstVars]) ifTrue: [
	^'Found expected class'.
].
newClass := Object subclass: 'GsPackagePolicy'
  instVarNames: #( enabled homeSymbolDict externalSymbolList
                    authorInitials sessionMethodDictionary)
  classVars: #()
  classInstVars: #( restrictedClasses)
  poolDictionaries: #[]
  inDictionary: Globals
  constraints: #[  ]
  instancesInvariant: false
  isModifiable: false.
  ^(oldClass isNil ifTrue: ['Created new class: '] 
                   ifFalse: ['Replaced old class with: ']) ,newClass definition.
%

! Remove existing behavior from GsPackagePolicy
expectvalue true
doit
GsPackagePolicy removeAllMethods.
GsPackagePolicy class removeAllMethods.
true
%

! ------------------- Class methods for GsPackagePolicy
category: 'Accessing'
classmethod: GsPackagePolicy
current

	| userGlobals sessionMethodPolicy |
	userGlobals := GsSession currentSession objectNamed: #UserGlobals.
	sessionMethodPolicy := userGlobals at: self globalName otherwise: nil.
	sessionMethodPolicy == nil
		ifTrue: [
			sessionMethodPolicy := self new.
			userGlobals at: self globalName put: sessionMethodPolicy
		].
	^sessionMethodPolicy
%
category: 'Accessing'
classmethod: GsPackagePolicy
globalName

	^#GsPackagePolicy_Current
%
category: 'Initialize'
classmethod: GsPackagePolicy
initialize

	(GsSession currentSession objectNamed: #UserGlobals) removeKey: self globalName ifAbsent: [ nil ].
%
category: 'Instance Creation'
classmethod: GsPackagePolicy
new

	^self basicNew initialize
%
category: 'Accessing'
classmethod: GsPackagePolicy
restrictedClasses
	"restrictedClasses := nil. self restrictedClasses"

  restrictedClasses == nil
    ifTrue: [
	restrictedClasses := #( BasicSortNode
        BtreeBasicInteriorNode
        BtreeBasicLeafNode
        BtreeComparisonForCompare
        BtreeComparisonForSort
        BtreeComparisonQuerySpec
        BtreeInteriorNode
        BtreeLeafNode
        BtreeNode
        BtreeReadStream
        BucketValueBag
        DependencyList
        DepListBucket
        DepListTable
        GciInterface
        GsCurrentSession
        GsMethod
        GsMethodDictionary
        GsSession
	  GsSessionMethodDictionary
	  GsPackagePolicy
	  GsPackage
        IdentityIndex
        IndexList
        IndexManager
        MappingInfo
        NscBuilder
        RangeEqualityIndex
        RcBtreeBasicInteriorNode
        RcBtreeBasicLeafNode
        RcBtreeInteriorNode
        RcBtreeLeafNode
        RcCollisionBucket
        RcIndexBucket
        RcIndexBucketWithCache
        RcIndexDictionary
        RcRangeEqualityIndex
        Repository
        Segment
        SegmentSet
        SymbolAssociation
        SymbolDictionary
        SymbolKeyValueDictionary
        SymbolList
        SymbolSet
        System
        UserProfile
        UserProfileSet
        UserSecurityData
      ).
    ].
  ^restrictedClasses
%
category: 'Method lookup control'
classmethod: GsPackagePolicy
loadSessionMethodDictionary
	"Install a SessionMethodDictionary,should only be called at session login"

	| policy notification |
	policy := (GsSession currentSession objectNamed: #UserGlobals) at: self globalName otherwise: nil.
	"Avoid installing anything if the policy is not enabled or does not exist"
	(policy ~~ nil _and: [ policy enabled ]) ifTrue: [ policy refreshSessionMethodDictionary ].

    "install a policy for handling TransactionBoundary notification"
    TransactionBoundaryDefaultPolicy isActive
        ifTrue: [ TransactionBoundaryDefaultPolicy installCurrent ].

    "login notification"
    SystemLoginNotification sessionStart.
%
category: 'Accessing'
classmethod: GsPackagePolicy
systemNotificationGlobalName

	^#GsPackagePolicy_SystemNotification
%

! ------------------- Instance methods for GsPackagePolicy
category: 'Accessing'
method: GsPackagePolicy
authorInitials
    "authorInitials stored in SessionTemps _not_ the IV. Don't want 
     authorInitials persisted"

	| ai |
	ai := SessionTemps current at: self authorInitialsGlobalName otherwise:nil.
	ai == nil 
		ifTrue:[
			ai := GsSession currentSession userProfile userId asString.
			SessionTemps current at: self authorInitialsGlobalName put: ai.
		].
	^ai
%
category: 'Accessing'
method: GsPackagePolicy
authorInitials: aString
    "authorInitials stored in SessionTemps _not_ the IV. Don't want 
     authorInitials persisted"

	SessionTemps current at: self authorInitialsGlobalName put: aString.
%
category: 'Categories'
method: GsPackagePolicy
addCategory: aSymbol for: aBehavior

  self homeSessionMethods addCategory: aSymbol for: aBehavior
%
category: 'Categories'
method: GsPackagePolicy
addSelector: aSelector toCategory: categoryName for: aBehavior

    self homeSessionMethods addSelector: aSelector toCategory: categoryName for: aBehavior.
%
category: 'Categories'
method: GsPackagePolicy
removeCategory: aSymbol for: aBehavior

	self packagesDo: [ :package |
		package removeCategory: aSymbol for: aBehavior.
	].
%
category: 'Categories'
method: GsPackagePolicy
categoryNamesFor: aBehavior into: anArray

	self packagesDo: [ :package |
		package categoryNamesFor: aBehavior into: anArray.
	].
%
category: 'Methods'
method: GsPackagePolicy
categoryOfSelector: aSymbol for: aBehavior

	self packagesDo: [ :package | | aKey |
		aKey := package categoryOfSelector: aSymbol for: aBehavior.
		aKey ~~ nil ifTrue: [ ^aKey ].
	].
	^nil
%
category: 'Methods'
method: GsPackagePolicy
compiledMethodAt: aSymbol for: aBehavior

	self packagesDo: [ :package | | meth |
		meth := package compiledMethodAt: aSymbol for: aBehavior.
		meth ~~ nil ifTrue: [ ^meth ].
	].
	^nil
%
category: 'Methods'
method: GsPackagePolicy
copyCategoryDictFor: aBehavior into: aGsMethodDictionary

	self packagesDo: [ :package |
		package copyCategoryDictFor: aBehavior into: aGsMethodDictionary.
	].
%
category: 'Methods'
method: GsPackagePolicy
copyMethodDictFor: aBehavior into: aGsMethodDictionary

	self packageReverseDo: [ :package |
		package copyMethodDictFor: aBehavior into: aGsMethodDictionary.
	].
%
category: 'Accessing'
method: GsPackagePolicy
sessionMethodDictionary: aGSSessionMethodDictionary
    "sessionMethodDictionary stored in SessionTemps _not_ the IV. Don't want 
     sessionMethodDictionary persisted"

    SessionTemps current at: self sessionMethodDictionaryGlobalName put: aGSSessionMethodDictionary.
%
category: 'Accessing'
method: GsPackagePolicy
sessionMethodDictionary
    "sessionMethodDictionary stored in SessionTemps _not_ the IV. Don't want 
     sessionMethodDictionary persisted"

    | sm |
    sm := SessionTemps current at: self sessionMethodDictionaryGlobalName otherwise: nil.
    sm == nil ifTrue: [ sm := self buildSessionMethodDictionary ].
    ^sm
%
category: 'Accessing'
method: GsPackagePolicy
disable

	enabled := false.
	self refreshSessionMethodDictionary.

%
category: 'Accessing'
method: GsPackagePolicy
enable

	enabled := true.
	self refreshSessionMethodDictionary.
%
category: 'Accessing'
method: GsPackagePolicy
enabled

	^enabled
%
category: 'Accessing'
method: GsPackagePolicy
externalSymbolList

	^externalSymbolList
%
category: 'Accessing'
method: GsPackagePolicy
externalSymbolList: anArray

	externalSymbolList := anArray
%
category: 'Accessing'
method: GsPackagePolicy
homeSessionMethods

	| package |
	package := self homeSymbolDict  at: GsPackage globalName otherwise: nil.
    package == nil ifTrue: [ package := GsPackage installIn: self homeSymbolDict ].
	^package
%
category: 'Accessing'
method: GsPackagePolicy
homeSymbolDict

	^homeSymbolDict
%
category: 'Accessing'
method: GsPackagePolicy
homeSymbolDict: aSymDict

	homeSymbolDict := aSymDict
%
category: 'Methods'
method: GsPackagePolicy
includesSelector: aSymbol for: aBehavior

	<primitive: 901>  "enter protected mode"
	| mDict ans |
	mDict := self sessionMethodDictionary at: aBehavior ifAbsent: [ ^false ].
	ans := mDict includesKey: aSymbol.
	System _disableProtectedMode.
	^ans
%
category: 'Initialize-Release'
method: GsPackagePolicy
initialize

    	| currentSession |
	enabled := false.
    	currentSession := GsSession currentSession.
	homeSymbolDict := currentSession objectNamed: #UserGlobals.
    	externalSymbolList := Array new.
%
category: 'Method lookup control'
method: GsPackagePolicy
refreshSessionMethodDictionary

	self sessionMethodDictionary: nil.
	self installSessionMethodDictionary.
%
category: 'Method lookup control'
method: GsPackagePolicy
installSessionMethodDictionary

	<primitive: 901>  "enter protected mode"

"
	sessionDict isEmpty
		ifTrue: [ GsCurrentSession currentSession installSessionMethodDictionary: nil ]
		ifFalse: [ GsCurrentSession currentSession installSessionMethodDictionary: self sessionMethodDictionary ].
"
	GsCurrentSession currentSession installSessionMethodDictionary: self sessionMethodDictionary.
	System _disableProtectedMode.
%
category: 'Compiling'
method: GsPackagePolicy
updateMethodLookupCacheFor: aGsMethod in: aBehavior

	<primitive: 901>  "enter protected mode"

	| sm mDict selector |
    sm := self sessionMethodDictionary.
	mDict := sm at: aBehavior otherwise: nil.
    mDict == nil
		ifTrue: [
			mDict := GsSessionMethodDictionary new.
			sm at: aBehavior put: mDict.
		].
	selector := aGsMethod selector.
	mDict at: selector put: aGsMethod.
	aBehavior _refreshLookupCache: selector oldMethod: nil .

    self sessionMethodChanged.

	System _disableProtectedMode.
%
category: 'Compiling'
method: GsPackagePolicy
methodAndCategoryDictionaryFor: aBehavior 
source: sourceString 
dictionaries: aSymbolList 
category: categorySymbol 
do: aBlock

	self enabled 
		ifTrue: [ | selectorOrError |
			selectorOrError := self
				extractSelectorOrErrorFor: aBehavior 
				source: sourceString 
				dictionaries: aSymbolList 
				category: categorySymbol.
			selectorOrError _class == Symbol ifFalse: [ ^aBlock value: nil value: nil value: selectorOrError ].
			(self permitSessionMethodFor: aBehavior selector: selectorOrError)
				ifTrue: [ 
            			^self homeSessionMethods 
						methodAndCategoryDictionaryFor: aBehavior 
                				do: aBlock.
				].
		].
	^aBlock value: nil value: nil value: nil
%
category: 'Compiling'
method: GsPackagePolicy
pragmasForMethod: selector in: aBehavior

	self packagesDo: [ :package | | pragmaDict pragmas |
		pragmaDict := package methodPragmaDictFor: aBehavior.
		pragmaDict ~~ nil 
			ifTrue: [ 
				pragmas := pragmaDict at: selector asSymbol otherwise: nil.
				pragmas ~~ nil ifTrue: [ ^pragmas ].
			].
	].
    ^nil
%
category: 'Compiling'
method: GsPackagePolicy
stampForMethod: selector in: aBehavior

	self packagesDo: [ :package | |stampDict stamp |
		stampDict := package methodStampDictFor: aBehavior.
		stampDict ~~ nil 
			ifTrue: [ 
				stamp := stampDict at: selector asSymbol otherwise: nil.
				stamp ~~ nil ifTrue: [ ^stamp ].
			].
	].
    ^nil
%
category: 'Private'
method: GsPackagePolicy
authorInitialsGlobalName

	^#GsPackagePolicy_AuthorInitials
%
category: 'Private'
method: GsPackagePolicy
sessionMethodDictionaryGlobalName

	^#GsPackagePolicy_SessionMethodDictionary
%
category: 'Private'
method: GsPackagePolicy
buildSessionMethodDictionary

	<primitive: 901>  "enter protected mode"

	| mDict sm |
	sm := GsSessionMethodDictionary new.
	sm keyConstraint: Behavior.
	sm valueConstraint: GsSessionMethodDictionary.
    	self packageReverseDo: [:package |
		package behaviorAndMethodDictDo: [:behavior :methodDict |
			mDict := sm at: behavior otherwise: nil.
                	mDict == nil
                  	ifTrue: [
                      		mDict := GsSessionMethodDictionary new.
                      		sm at: behavior put: mDict.
                  	].
               	methodDict keysAndValuesDo: [:k :v | mDict at: k put: v ].
            	].
 	].
	self sessionMethodDictionary: sm.
	System _disableProtectedMode.
	^sm
%
category: 'Private'
method: GsPackagePolicy
permitSessionMethodFor: aBehavior selector: selector

	| cl seg |
    	cl := aBehavior whichClassIncludesSelector: selector.
    	cl ~~ nil 
        	ifTrue: [
            	(cl compiledMethodAt: selector) _isProtected ifTrue: [ ^false ].
        	].
    	(self class restrictedClasses includes: aBehavior thisClass name) ifTrue: [ ^false ].
    	externalSymbolList do: [:symDict | 
		    (symDict includesKey: aBehavior thisClass name) ifTrue: [ ^true ].
	].
	seg := aBehavior segment.
	^seg == nil
		ifTrue: [ false ]
		ifFalse: [ seg currentUserCanWrite not ]
%
category: 'Private'
method: GsPackagePolicy
extractSelectorOrErrorFor: aBehavior 
source: sourceString 
dictionaries: aSymbolList 
category: categorySymbol 

	| mDict cDict meth symList |
	aSymbolList class == SymbolList
  		ifTrue:[ symList := aSymbolList ]
  		ifFalse:[
    			aSymbolList _validateClass: Array .
    			symList := SymbolList withAll: aSymbolList .
    		] .
	mDict := GsMethodDictionary new.
	cDict := GsMethodDictionary new.
	meth := aBehavior
		_primitiveCompileMethod: sourceString
		symbolList: symList 
		category: categorySymbol 
		oldLitVars: nil 
		intoMethodDict: mDict 
		intoCategories: cDict intoPragmas: nil .
	meth class ~~ GsMethod 
		ifTrue: [ 
			"if error slot is not nil, then the method wasn't compiled because of errors"
			(meth at: 2) == nil ifFalse: [ ^(meth at: 2) "errorArray" ].
			meth := (meth at: 1).
		].
    ^meth selector.
%
category: 'Methods'
method: GsPackagePolicy
selectorsFor: aBehavior into: anArray

	<primitive: 901>  "enter protected mode"
	| mDict  |
	mDict := self sessionMethodDictionary at: aBehavior ifAbsent: [ ^self ].
	anArray addAll: mDict keys.
	System _disableProtectedMode.
	^self
%
category: 'Categories'
method: GsPackagePolicy
selectorsIn: categoryName for: aBehavior into: anArray

	self packagesDo: [ :package |
		package selectorsIn: categoryName for: aBehavior into: anArray.
	].
%
category: 'Enumerating'
method: GsPackagePolicy
packagesDo: aBlock
	| package |
	self enabled ifFalse: [ ^self ].
    self symbolList do: [:symDict |
      	package := symDict at: GsPackage globalName otherwise: nil.
      	package ~~ nil ifTrue: [ aBlock value: package ].
	].
%
category: 'Enumerating'
method: GsPackagePolicy
packageReverseDo: aBlock
	| package |
	self enabled ifFalse: [ ^self ].
    	self symbolList reverseDo: [:symDict |
      	package := symDict at: GsPackage globalName otherwise: nil.
      	package ~~ nil ifTrue: [ aBlock value: package ].
	].
%
category: 'Compiling'
method: GsPackagePolicy
setPragmas: pragmaArray
forBehavior: aBehavior
forMethod: selector

	| aSym |
	aSym := selector asSymbol.
	self packagesDo: [ :package |  
		(package 
			setPragmas: pragmaArray 
        	forBehavior: aBehavior
        	forMethod: selector) ~~ nil
		ifTrue: [ ^self ].
	].
	^nil
%
category: 'Compiling'
method: GsPackagePolicy
setStamp: aStamp 
forBehavior: aBehavior
forMethod: selector

	| aSym |
	aSym := selector asSymbol.
	self packagesDo: [ :package |  
		(package 
			setStamp: aStamp 
        		forBehavior: aBehavior
        		forMethod: selector) ~~ nil
		ifTrue: [ ^self ].
	].
	^nil
%
category: 'Accessing'
method: GsPackagePolicy
symbolList

	^GsSession currentSession symbolList
%
category: 'Methods'
method: GsPackagePolicy
removeMethodAt: aSymbol for: aBehavior

    self packagesDo: [ :package | | meth |
		meth := package removeMethodAt: aSymbol for: aBehavior.
		meth ~~ nil ifTrue: [ ^meth ].
	].
    "fix up the session method dictionary"
    self sessionMethodRemoveMethodAt: aSymbol for: aBehavior.
	^nil
%

category: 'Methods'
method: GsPackagePolicy
removeAllMethodsFor: aBehavior

	| sm mDict |
	self packagesDo: [ :package |
		package removeAllMethodsFor: aBehavior.
	].
    "fix up the session method dictionary"
    self sessionMethodRemoveAllMethodsFor: aBehavior.
	^nil
%

category: 'Methods'
method: GsPackagePolicy
removeAllSubclassCodeFor: aBehavior

"Dereference the code objects of all GsMethods for aBehavior,
 to force recompilation of those methods."

	self packagesDo: [:package |
		package removeAllSubclassCodeFor: aBehavior.
	].
    self sessionMethodRemoveAllSubclassCodeFor: aBehavior.
%
category: 'Transaction Boundaries'
method: GsPackagePolicy
sessionMethodChanged

    TransactionBoundaryDefaultPolicy isActive
        ifTrue: [ TransactionBoundaryDefaultPolicy current sessionMethodChanged].
%
category: 'Private'
method: GsPackagePolicy
sessionMethodRemoveMethodAt: aSymbol for: aBehavior

	<primitive: 901>  "enter protected mode"

	| sm mDict |
    sm := self sessionMethodDictionary.
	mDict := sm at: aBehavior otherwise: nil.
    mDict ~~ nil
		ifTrue: [
            mDict 
                removeKey: aSymbol 
                ifAbsent: [ 
                    System _disableProtectedMode.
                    ^self ].
            aBehavior _refreshLookupCache: aSymbol oldMethod: nil.
            self sessionMethodChanged].
	System _disableProtectedMode.
%
category: 'Private'
method: GsPackagePolicy
sessionMethodRemoveAllMethodsFor: aBehavior

	<primitive: 901>  "enter protected mode"

	| sm |
    sm := self sessionMethodDictionary.
    sm 
        removeKey: aBehavior 
        ifAbsent: [ 
          System _disableProtectedMode.
          ^self ].
    aBehavior _refreshClassCache.

    self sessionMethodChanged.

	System _disableProtectedMode.
%
category: 'Private'
method: GsPackagePolicy
sessionMethodRemoveAllSubclassCodeFor: aBehavior

	<primitive: 901>  "enter protected mode"

    self sessionMethodDictionary 
        at: aBehavior 
        ifAbsent: [ 
            System _disableProtectedMode.
            ^ self ].

	System _disableProtectedMode.

    "All methods in aBehavior have been marked for recompilation, 
     and we have entries in the sessionMethodDictionary for Behavior, 
     so refresh sessionMethodDictionary."

    self refreshSessionMethodDictionary.
%

category: 'Categories'
method: GsPackagePolicy
removeSelector: aSelector fromCategoriesFor: aBehavior

    self packagesDo: [ :package |
		package removeSelector: aSelector fromCategoriesFor: aBehavior].
%

