!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: gscurrsession.gs,v 1.20 2008-01-09 22:50:11 stever Exp $
!
! Superclass Hierarchy:
!   GsCurrentSession, GsSession, AbstractSession, Object
!=========================================================================

expectvalue %String
run
| oldCls newCls |
oldCls := Globals at:#GsCurrentSession otherwise: nil .
oldCls == nil ifTrue:[
  GsSession _newKernelSubclass: 'GsCurrentSession'
        instVarNames: #( 'symbolList' 'nativeLanguage' )
        classVars: #()
        classInstVars: #()
        poolDictionaries: #[]
        inDictionary: Globals
        constraints: #[ #[ #symbolList, SymbolList],
			#[ #nativeLanguage, String ]  ]
        instancesInvariant: false
        isModifiable: true
        reservedOop: 813 .

  newCls := (Globals at:#GsCurrentSession) .
  newCls disallowSubclasses immediateInvariant .
  ^ 'created new class: ' , newCls definition
  ]
ifFalse:[
  ^ 'existing class: ' , oldCls definition
  ]
%

removeallmethods  GsCurrentSession
removeallclassmethods  GsCurrentSession

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

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

txt := (GsDocText new) details:
'GsCurrentSession provides a public interface to the current GemStone session.
 There is only one instance of GsCurrentSession in each GemStone session.
 The GemStone server creates it automatically when a user logs into GemStone.
 The instance is transient and cannot be accessed after the user logs out of
 GemStone.' .
doc documentClassWith: txt.

txt := (GsDocText new) details:
'The SymbolList that is used for default Symbol resolution in the current
 GemStone session.  Its value is initially a copy of the SymbolList of the
 current user''s UserProfile.  While its value can be modified during the
 session, such modifications are transient and last only as long as the current
 session.

 Modifications should be handled with care to avoid unintended side effects in
 Symbol resolution during the current session.  When methods need to create a
 different transient Symbol resolution environment, it is often preferable to
 copy this SymbolList first and use the modified copy explicitly where it is
 needed.' .
doc documentInstVar: #symbolList with: txt.

txt := (GsDocText new) details:
'A String (normally a Symbol) that controls error message generation in the
 current session.  GemStone automatically executes the message

 System myUserProfile objectNamed: #NativeLanguage

 at login, and assigns the result to this instance variable.  For default
 UserProfiles, the result is #English.' .
doc documentInstVar: #nativeLanguage with: txt.

self description: doc.
%

! The GsCurrentSession instance is transient and needs to be kept explicitly in
! the NoRollbackSet.
!
! Subclassing of GsCurrentSession is disallowed so that instance variables
! can be added by GemStone in later releases without affecting customer
! customizations or forcing rewriting of customer subclasses.

category: 'Instance Creation'
classmethod: GsCurrentSession
new

"Disallowed.

 The only instance of GsCurrentSession that is permitted in a session is created
 automatically when a user logs in to GemStone.  Its default SymbolList is a
 copy of the user's SymbolList.  You can obtain that instance by sending the
 message GsSession currentSession."

self shouldNotImplement: #new.
self _uncontinuableError . 
%

category: 'Accessing'
method: GsCurrentSession
nativeLanguage

"Returns the String that designates the language that controls error message
 generation in the current session."

^ nativeLanguage
%

category: 'Accessing the Symbol List'
method: GsCurrentSession
objectNamed: aSymbol 

"Returns the first object in the receiver's symbol list that has the given
 name.  If no object with the given name is found, returns nil."

| assn |

assn := symbolList resolveSymbol: aSymbol.
assn == nil ifTrue: [ ^nil ].
^assn value
%

category: 'Accessing the Symbol List'
method: GsCurrentSession
resolveSymbol: aSymbol 

"Searches the receiver's symbol list for an Association whose key is equal to
 aString, and returns that Association.  If no such Association is found in the
 symbol list, returns nil.

 Implemented to use the current session's transient copy of the symbol list.
 This method is the default mechanism for symbol-resolution during 
 compilation of GemStone Smalltalk methods."

^ symbolList resolveSymbol: aSymbol 
%

category: 'Accessing the Symbol List'
method: GsCurrentSession
symbolList 

"Implemented to use the current session's transient copy of the symbol list."

^ symbolList
%

category: 'Signalling'
method: GsCurrentSession
signalFromSession 

"Return a GsInterSessionSignal object containing information about a signal from
 another session, or nil if there is no signal waiting."

| sigArray result |
sigArray := System _signalFromGemStoneSession .
sigArray == nil ifTrue:[ ^ nil ].
result := GsInterSessionSignal signal: (sigArray at: 2) 
			      message: (sigArray at: 3) .
result session: (GsSession sessionWithSerialNumber: (sigArray at: 1)).
^ result
%

category: 'Instance Creation'
classmethod: GsCurrentSession
currentSession

"Returns the sole instance of GsCurrentSession that represents this login
 session."

<primitive: 311>
self _primitiveFailed: #currentSession
%

category: 'Session Configuration Access'
method: GsCurrentSession
configurationAt: aSymbol

"Returns the value of the configuration parameter named aSymbol (for example,
 #GEM_HALT_ON_ERROR).  Raises an error if aSymbol is not a valid parameter
 name."

^ System configurationAt: aSymbol
%

category: 'Session Configuration Access'
method: GsCurrentSession
configurationAt: aSymbol put: anObject 

"Sets the value of the configuration parameter named aSymbol to anObject.  
 Raises an error if aSymbol is not a valid parameter name or anObject is an
 inappropriate value for the parameter."

^ System configurationAt: aSymbol put: anObject
%

category: 'Session Configuration Access'
method: GsCurrentSession
sessionVersionAt: aSymbol 

"Returns the value of the GsSession's Gem version information parameter 
 named aSymbol."

^ System gemVersionAt: aSymbol
%

category: 'Session Configuration Access'
method: GsCurrentSession
clientVersionAt: aSymbol 

"Returns the value of the GsSession's client version information parameter named
 aSymbol.  Returns nil if no version parameter named aSymbol exists."

^ System clientVersionAt: aSymbol
%

category: 'Session Configuration Access'
method: GsCurrentSession
serverVersionAt: aSymbol 

"Returns the value of the GsSession's Stone version information parameter named
 aSymbol."

^ System stoneVersionAt: aSymbol
%

category: 'Session Configuration Access'
method: GsCurrentSession
configurationParameters 

"Returns a Set of Symbols containing the names of all valid configuration
 parameters for this GsSession."

^ ConfigurationParameterDict keys
%

category: 'Session Configuration Access'
method: GsCurrentSession
versionParameters 

"Returns a Set of Strings containing the names of all valid version parameters
 for this GsSession."

^ VersionParameterDict keys
%

category: 'Smalltalk Execution'
method: GsCurrentSession
execute: aString 

"Executes aString containing GemStone Smalltalk code in the session represented
 by the receiver.  Symbol resolution is from the default symbol list."

^ ( aString _compileInContext: nil symbolList: symbolList ) 
     _executeInContext: nil
%

category: 'Smalltalk Execution'
method: GsCurrentSession
execute: aString symbolList: aSymbolList 

"Executes aString containing GemStone Smalltalk code in the session represented
 by the receiver.  Symbol resolution is from the given symbol list."

^ ( aString _compileInContext: nil symbolList: aSymbolList ) 
     _executeInContext: nil
%

category: 'Transaction Control'
method: GsCurrentSession
abortTransaction

"Rolls back all modifications made to committed GemStone objects and provides
 the session with a new view of the most current committed state of the
 repository.

 These operations are performed whether or not the session was previously in a
 transaction.  If the transaction mode is set to #autoBegin, then a new
 transaction is started.  If the transaction mode is set to #manualBegin, then
 a new transaction is not started."

System abortTransaction
%

category: 'Transaction Control'
method: GsCurrentSession
beginTransaction

"Starts a new transaction for the session.  If the session is already
 in a transaction, aborts the current transaction and starts a new transaction.

 If the session changed any permanent objects without committing them, their
 state is aborted."

System beginTransaction
%

category: 'Transaction Control'
method: GsCurrentSession
commitAndReleaseLocks

"Attempts to commit the transaction for the session.

 This method is the same as 'commitTransaction' except for the handling of
 locks.  If the commit succeeds, this method releases all locks for the session
 and returns true.  Otherwise, it returns false and does not release locks.

 This method also clears the commit release locks and commit-or-abort release
 locks sets.  See the 'Releasing Locks' method category in class System for 
 more information."

^ System commitAndReleaseLocks
%

category: 'Transaction Control'
method: GsCurrentSession
commitTransaction

"Attempts to update the persistent state of GemStone to include changes made
 by this session.

 If the commit operation succeeds, then this method returns true, and the
 current transaction's changes, if any, become a part of the persistent
 repository.  After the repository update, the session exits the current
 transaction.  If the transaction mode is autoBegin, then the session enters
 a new transaction.  If the transaction mode is #manualBegin, then the session
 remains outside of a transaction.

 If conflicts prevent the repository update, then this method returns false.
 Call the transactionConflicts method to determine the nature of the
 conflicts.  If the session is outside of a transaction, then this method
 raises the error #rtErrPrimOutsideTrans.

 This method also updates the session's view of GemStone.  If the commit
 operation succeeds, then all objects in the session's view are consistent with
 the current state of GemStone.  If the commit fails, then this method retains
 all the changes that were made to objects within the current transaction.
 However, commits made by other sessions are visible to the extent that changes
 in this transaction do not conflict with them."

^ System commitTransaction
%

category: 'Transaction Control'
method: GsCurrentSession
continueTransaction

"Updates the session's view to the most recently committed state of GemStone
 without rolling back modifications made to committed objects in the session.
 The read and write sets of the session are carried forward and continue to
 accumulate until the session either commits or aborts.  Changes made by this
 session to committed objects are not visible to other sessions until the
 session commits.

 Returns true if accumulated modifications to the committed state of GemStone
 would not cause concurrency conflict as of the new view; otherwise returns
 false.  If it returns false, you can call the transactionConflicts method to
 determine the nature of the conflicts.

 This method can be used whether or not the session is outside of a transaction.
 Of course, the session cannot commit the accumulated changes unless it is
 inside a transaction.

 If transaction mode is #manualBegin, then continueTransaction does not alter
 the inside/outside of transaction state of the session.

 Modifications made by other committed transactions are accumulated for
 retrieval by GciDirtyObjs() and GciDirtySavedObjs() just as they are
 accumulated for commitTransaction or abortTransaction.

 This method has no effect on object locks held by the session.  Locks in the
 release locks sets are not released."

^ System continueTransaction
%

category: 'Transaction Control'
method: GsCurrentSession
inTransaction

"Returns true to indicate that the session is in a transaction, false
 otherwise."

^ System _zeroArgPrim: 5
%

category: 'Transaction Control'
method: GsCurrentSession
transactionMode

"Returns the current transaction mode for the current GemStone session, either
 #autoBegin, #manualBegin or #transactionless.  The default is #autoBegin."

^ System _zeroArgPrim: 4
%

category: 'Transaction Control'
method: GsCurrentSession
transactionMode: newMode

"Sets a new transaction mode for the current GemStone session and exits the
 previous mode by aborting the current transaction.  Valid arguments are
 #autoBegin, #manualBegin or #transactionless.  
 The mode transactionless is intended primarily for idle sessions. Users
 may scan database objects, but are at risk of obtaining inconsistent views.
 When in transactionless mode, the session is exempt from voting on 
 possibleDeadObjs and will not be terminated by STN_GEM_TIMEOUT expiring.
"

System transactionMode: newMode
%

! fixed 31100
category: 'Transaction Control'
method: GsCurrentSession
hasConflicts

"Determines, given the present state of the receiver, if any concurrency
 conflicts exist that would cause a subsequent commit operation to fail.
 Returns false if it finds no conflicts with other concurrent transactions.
 Returns true if it does find conflicts, which can then be examined by
 calling the System class>>transactionConflicts method.

 This method has meaningful results whether or not the receiver is currently
 running inside a transaction.

 Note:  Even if this method returns false, there is no guarantee that a
        subsequent commit operation will succeed.

 If certain updates have been made to reduced conflict objects, it cannot
 be determined until a commit is attempted whether or not a conflict exists.
 In the following cases, this method always returns true:

   * Any change to an RcPositiveCounter during the current session.
   * One or more removals from an RcIdentityBag during the current session.
   * A session performs both additions and removals from an RcQueue which
     it has not accessed in this transaction or previous transactions.
"

 | result systm |
 systm := System .
 result := systm _validateTransaction.
 result == -1 ifTrue:[ ^ false "read-only transaction" ].   
 result == 0 ifTrue: [ 
    (systm _hiddenSetSize: 7) == 0
       ifTrue: [ ^ false ]
       ifFalse: [^ self _scanRedoLogForConflicts ]
  ] ifFalse: [
    result == 1
      ifTrue: [ ^ self _RcHasConflicts  ]
      ifFalse: [ ^ true "validationFailure" ]
  ].
  self halt: 'logic error' .
  ^ true "if we get here it is a logic error, but indicate conflicts exist"
%

category: 'Reduced Conflict Support'
method: GsCurrentSession
_RcHasConflicts

"Do the hasConflicts check for Rc objects but do not selectively abort."

| scanArray redoObject conflicts|

scanArray := System _getRedoAndConflictObjects.
" if no redo objects were found, cannot resolve conflicts "
scanArray == nil ifTrue: [ ^ true ].

1 to: scanArray size by: 2 do: [ :i |
  redoObject := scanArray at: i.
  conflicts := scanArray at: i + 1.
  
  (redoObject _validateRcConflictsWith: conflicts)
    ifFalse: [ ^ true ]
].
^false
%

category: 'Reduced Conflict Support'
method: GsCurrentSession
_scanRedoLogForConflicts

"Scan the redo log for entries on RC objects that could conflict
on replay.  If we find one, return true, indicating that we do not
know if we can replay successfully without selectively aborting."

| redoLog |
(redoLog := System _redoLog) == nil
  ifTrue: [ ^ false ].

redoLog redoObjects keysAndValuesDo: [ :redoObj :logEntries |
  (redoObj _validateRcConflictsWith: #())
    ifFalse: [ ^ true ]
].
^ false
%

category: 'Session Control'
method: GsCurrentSession
reloginAsUser: aUserId withEncryptedPassword: aPassword

"The session aborts its current transaction, if any, and attempts a relogin
 with the specified userid and encrypted password.  Errors in login leave
 the session in the idle state, as if logoutAndGoIdle had been successfully
 executed."

| result |
result := System _reloginAsUser: aUserId password: aPassword encrypted: true.
(System hasUserAction: #_topazReloginCallback) 
  ifTrue: [ System userAction: #_topazReloginCallback ].

result ifFalse: [System _error: #rtErrWarningPasswordExpire]
       ifTrue: [System transactionMode: #autoBegin]
%

category: 'Session Control'
method: GsCurrentSession
reloginAsUser: aUserId withPassword: aPassword

"The session aborts its current transaction, if any, and attempts a relogin
 with the specified userid and password.  Errors in login leave the session 
 in the idle state, as if logoutAndGoIdle had been successfully executed."

| result |
result := System _reloginAsUser: aUserId password: aPassword encrypted: false.

(System hasUserAction: #_topazReloginCallback) 
  ifTrue: [ System userAction: #_topazReloginCallback ].

result ifFalse: [System _error: #rtErrWarningPasswordExpire]
       ifTrue: [System transactionMode: #autoBegin]
%

category: 'Session Control'
method: GsCurrentSession
logoutAndGoIdle

"The session performs a relogin as the Nameless user and goes idle by
 setting the transactionMode to #transactionless."

| namelessUserProfile |
namelessUserProfile := AllUsers userWithId: 'Nameless' ifAbsent: [self error: 'There is no Nameless user profile.'].

System currentSegment: namelessUserProfile defaultSegment.
System abortTransaction.
System _generationScavenge.
self reloginAsUser: 'Nameless' withPassword: ''.
self transactionMode: #transactionless.

%
category: 'Initialization'
method: GsCurrentSession
initialize

" This method is executed once at Session initialization,
  after the ProcessorScheduler is initialized.  It is invoked from
  ProcessorScheduler >> _initialize . 

  This method may be modified to invoke application specific 
  initialization code.  
"

"install a sessionMethodDictionary if GsPackagePolicy is enabled"
GsPackagePolicy loadSessionMethodDictionary.

^ self
%
category: 'Method lookup control'
method: GsCurrentSession
_installSessionMethodDict: aDict

"Installs aDict as the SessionMethods dictionary for
 the current session. 

 If successful(i.e. primitive did not fail) all
 method lookup caches in the VM are cleared. 
 "

<protected primitive: 650>
self _primitiveFailed: #_installSessionMethodDict:
%

category: 'Method lookup control'
method: GsCurrentSession
installSessionMethodDictionary: aDict

"Installs aDict as the SessionMethods dictionary for
 the current session.  

 aDict must be a GsMethodDictionary 
 with keyConstraint == Behavior and valueConstraint == GsMethodDictionary .

 Each value in aDict should be a GsMethodDictionary with keys Symbols and
 values GsMethods .

 After successful execution of this method, for each Behavior which
 is a key in aDict,  methods in the dictionary which is the value
 for that key  will  take precedence over methods in the Class's 
 method dictionary.

 The execution of this method has no effect on committed state;
 you must invoke this method in each new session if you want
 to install per-session methods .
"

"if you relax  aDict class  constraint  , ensure that
 you don't subvert code modification privilege "

aDict class == GsSessionMethodDictionary ifFalse:[
  self _error:'argument must be a GsSessionMethodDictionary'
].
aDict keyConstraint == Behavior ifFalse:[
  self _error:' invalid key constraint'
].
aDict valueConstraint == GsSessionMethodDictionary ifFalse:[
  self _error:' invalid value constraint'
].

self _installSessionMethodDict: aDict .
%
