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

removeallmethods Segment
removeallclassmethods Segment

run
	"Gs64 v2.2, rename instvar spare1 to segmentId, 
         and prevent GCI creation or modification" 
| ivns oldName |
ivns := Segment _instVarNames .
oldName := (ivns at: 7) .
oldName == #spare1 ifTrue:[
  "use _unsafeAt:put: to bypass invariance during repository conversion"
  ivns _unsafeAt: 7 put: #segmentId .
  Segment _constraints _unsafeAt: 7 put: SmallInteger .
] ifFalse:[
  oldName == #segmentId ifFalse:[
    nil error: 'bad ivName ' , oldName asString .
  ].
].
^ true
%

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

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

txt := (GsDocText new) details:
'Each Repository is composed of an integral number of Segments.  A Segment has
 the following properties:

 * Ownership.  This is the smallest unit of ownership for accounting and
   authorization purposes.  Each Segment is owned by one and only one user.

 * Authorization unit.  A user may control access to objects by placing them in
   a Segment with a known authorization.  Prior to reading or writing an object
   in a Segment, users must be authorized to perform the desired action.
   However, during a transaction, once a user is authorized to read one object
   in a Segment, that user can read any object in the same Segment.

 Segments and Repositories are discussed in more detail in the GemStone
 Programming Guide.

Text added as of Gs64 v2.2:
  All objects have a segmentId attribute, which is stored in the object
  header.  
  References from an object to its Segment are indirect via the
  SystemRepository object.  (See implementation of method Object >> segment ) 
  In a Repository that was converted from Gs64 v1.x , v2.0 or v2.1 ,
  all objects created prior to the conversion will have segmentId 0 .

  Read authorization is checked when an object is faulted or refreshed
  into memory , once in memory no further read authorization checks
  are performed.  No checks are done for an object with segmentId 0 .

  Write authorization is checked the first time an object is written
  during each transaction.  No checks are done for an object
  with segmentId 0 .

  Changes to Segment, UserProfile , or Group objects that affect
  read or write authorization checks are only guaranteed to be noticed
  after the next login.  This is different from Gemston/S 6.x , in which
  authorization changes are supposed to be noticed at the
  next transaction boundary.  Changes to the segmentId of an object
  will take effect on the next transaction boundary.

  Creation of Segments and changes to attributes of Segments require
  write authorization permission to the DataCuratorSegment .

  If you are logged in as SystemUser , no authorization errors will occur .

  All instances of Symbol, DoubleByteSymbol must be in a segment with 
  World read permission. By default they are on DataCuratorSegment .
 
  For logins other than SystemUser,
  the virtual machine requires read access to both DataCuratorSegment
  and SystemSegment in order to be able to bootstrap object memory
  as part of a session login.  Specifically , well known classes
  such as Metaclass, Object, etc are expected to be in SystemSegment ,
  and instances of Symbol and objects such as SystemRepository are
  expected to be in DataCuratorSegment.  To avoid infinite recursion
  in loading the authorization cache, the virtual machine preloads
  authorization for SystemSegment and DataCuratorSegment after validating
  the userId/password , and will generate a fatal error if it does not
  have read access to both DataCuratorSegment and DataCuratorSegment.

  All instances of UserProfile,  IdentitySets representing Groups, 
  and Segments must be in a segment with World read permission. 
  By default they are on DataCuratorSegment.

  During repository conversion from a prior release to Gs64 v2.2 ,
  if the previous size of SystemRepository was < 20 , and
  a  Segment will be created with segmentId 20 and world write, 
  to handle the case where an older version of GBS clients
  may have created objects in a Gs64 v2.0 or v2.1 repository
  with segmentId 20 .
'.
doc documentClassWith: txt.

txt := (GsDocText new) details:
'This variable is obsolete in GemStone v5.0 and is provided only for
 compatibility with earlier releases.' .
doc documentClassVar: #AuthorizationMasks with: txt.

txt := (GsDocText new) details:
'This variable is obsolete in GemStone v5.0 and is provided only for
 compatibility with earlier releases.' .
doc documentClassVar: #AuthorizationFactors with: txt.

txt := (GsDocText new) details:
'This variable is obsolete in GemStone v4.1 and is provided only for
 compatibility with earlier releases.' .
doc documentClassVar: #AuthorizationSymbols with: txt.

txt := (GsDocText new) details:
'The Repository containing the Segment.'.
doc documentInstVar: #itsRepository with: txt.

txt := (GsDocText new) details:
'A UserProfile indicating the owner of the Segment.'.
doc documentInstVar: #itsOwner with: txt.

txt := (GsDocText new) details:
'An IdentitySet of canonical Strings.  Each String must be an element of
 AllGroups, and represents a group of users who are authorized to access
 the Segment for reading.'.
doc documentInstVar: #groupsRead with: txt.

txt := (GsDocText new) details:
'An IdentitySet of canonical Strings.  Each String must be an element of
 AllGroups, and represents a group of users who are authorized to access
 the Segment for writing.'.
doc documentInstVar: #groupsWrite with: txt.

txt := (GsDocText new) details:
'A SmallInteger specifying authorization for the owner to access the Segment.
 0 = no access, 1 = read access, 2 = write access.'.
doc documentInstVar: #ownerAuthorization with: txt.

txt := (GsDocText new) details:
'A SmallInteger specifying world authorization to access the Segment.
 0 = no access, 1 = read access, 2 = write access.'.
doc documentInstVar: #worldAuthorization with: txt.

txt := (GsDocText new) details:
'A SmallInteger > 0, 
 the offset of this Segment in the object SystemRepository. '.
doc documentInstVar: #segmentId with: txt.

txt := (GsDocText new) details:
'Methods in this category are obsolete and are provided only for compatibility
 with earlier releases of GemStone.  They will be removed in a future release.'.
doc documentCategory: #'Backward Compatibility' with: txt.

self description: doc.
%

category: 'Instance Creation'
classmethod: Segment
newInRepository: aRepository

"Returns a new Segment in the Repository aRepository.  If the maximum number of
 Segments has already been created for aRepository, this generates an error.
 The new Segment is owned by the UserProfile of the current session, and
 has the default authorization of W----- (owner can read and write).  

 After execution of this method, the current transaction must be committed
 before objects can be created in the Segment, object assigned to the
 segment, or the Segment used as argument to a defaultSegment: keyword in 
 creation of UserProfiles.

 Requires the SegmentCreation privilege and WriteAccess to DataCuratorSegment.
 "

<primitive: 291>
aRepository _validateClass: Repository.
self _primitiveFailed: #newInRepository: .
self _uncontinuableError
%

category: 'Accessing'
method: Segment
groups

"Returns an IdentitySet, the set of user groups (Strings) that are
 explicitly authorized to read or write in this Segment."

| result |
groupsRead ~~ nil ifTrue:[ result := groupsRead ] 
                 ifFalse:[ result := IdentitySet new ].
groupsWrite ~~ nil ifTrue:[ result := result + groupsWrite ].
^ result
%

category: 'Accessing'
method: Segment
number

"Returns the index of the receiver in its Repository"

^ segmentId
%

category: 'Accessing'
method: Segment
segmentId

"Returns the index of the receiver in its Repository"

^ segmentId
%

category: 'Accessing'
method: Segment
owner

"Returns the UserProfile of the receiver's owner."

^ itsOwner
%

category: 'Accessing'
method: Segment
repository

"Returns the Repository containing the receiver."

^ itsRepository
%


category: 'Updating'
method: Segment
owner: aUserProfile

"Redefines the receiver's owner to be the user represented by aUserProfile.
 To execute this method, you must be authorized to write in the receiver's
 Segment (customarily, the DataCurator Segment)."

itsOwner := aUserProfile
%

category: 'Formatting'
method: Segment
asString

"Returns a formatted String that contains the following information:

 The name of the Repository containing the receiver and the index of
 the receiver in that Repository.

 * The user ID of the receiver's owner.

 * The Symbol that defines each user group which is authorized to read or
   write in the receiver.

 * Information about whether the receiver's owner, each group, or all
   users are authorized to read or write in the receiver.

 For example, the message 'System myUserProfile defaultSegment asString'
 returns a String that resembles the following:

 aSegment, Number 1 in Repository SystemRepository, Owner SystemUser write, World read

 If the receiver is not a Segment in the SystemRepository, the String contains
 'NOT IN REPOSITORY' in place of the index."

| tempString theGroupAuthString |

tempString := String new.  " string to return "
theGroupAuthString := String new.  " string of group authorizations"

"groups and build a single string to describe group authorizations."
groupsRead size > 0 ifTrue:[
  (groupsRead sortAscending:  '' ) do: [:groupName | 
     theGroupAuthString addAll: ' Group ';
                 addAll: (groupName asString);
                 add: ' ';
                 addAll: 'read' ; add: $, .
  ].
].
groupsWrite size > 0 ifTrue:[
  (groupsWrite sortAscending:  '' ) do: [:groupName | 
     theGroupAuthString addAll: ' Group ';
        addAll: (groupName asString);
        add: ' ';
        addAll: 'write' ; add: $, .
  ].
].

tempString " Build the string to return"
             addAll: 'aSegment, Number ';
             addAll: self segmentId  asString ;
             addAll: ' in Repository ';
             addAll: (self repository name); add: $, ;
             addAll: ' Owner ';
             addAll: (self owner userId);   add: $   ; 
             addAll: (self ownerAuthorization); add: $, ;
             addAll: theGroupAuthString;
             addAll: ' World ';
             addAll: (self worldAuthorization).

^tempString
%

category: 'Clustering'
method: Segment
clusterDepthFirst

"This method clusters the receiver.  (Overrides the inherited method, which
 also clusters all instance variables.)  Returns true if the receiver has 
 already been clustered during the current transaction, false otherwise."

  self cluster ifTrue:[ ^ true ].
  groupsRead cluster .
  groupsWrite cluster .
^ false
%

category: 'Copying'
method: Segment
copy

"Returns the receiver. Copies of segments are not made."

^ self.
%

category: 'Copying'
method: Segment
_deepCopyWith: copiedObjDict

"Private. Used internally to implement deepCopy."

^ self.
%

category: 'Accessing Authorization'
method: Segment
authorizationForGroup: aGroupString

"Returns a Symbol that defines whether the specified group is authorized to
 write (and read) in this Segment (#write), to read only (#read), or neither
 (#none)."

| canonGroup |
canonGroup := AllGroups at: aGroupString otherwise: nil .
canonGroup == nil ifTrue:[ ^ #none ].

groupsWrite size > 0 ifTrue:[
  (groupsWrite includesIdentical: canonGroup) ifTrue:[ ^ #write ]
  ].
groupsRead size > 0 ifTrue:[ 
  (groupsRead includesIdentical: canonGroup) ifTrue:[ ^ #read ]
  ].
^ #none
%

category: 'Accessing Authorization'
method: Segment
authorizationForUser: aUserProfile

"Returns a Symbol that describes the authorization that the given user has for
 the receiver."

| userGroups curAuth |

"Consider world authorization"
curAuth := worldAuthorization.
curAuth == 2 ifTrue: [ ^ #write ].

"Owner authorization applicable?"
itsOwner == aUserProfile ifTrue: [
  ownerAuthorization == 2 ifTrue:[ ^ #write ].
  curAuth := curAuth bitOr: ownerAuthorization .
  ].

"Consider group authorizations..."
userGroups := aUserProfile groups .
userGroups size > 0 ifTrue:[
  groupsWrite size > 0 ifTrue:[
    (groupsWrite * userGroups) size > 0 ifTrue:[ ^ #write ].
    ].
  groupsRead size > 0 ifTrue:[
    (groupsRead * userGroups) size > 0 ifTrue:[ curAuth := curAuth bitOr: 1 ].
    ].
  ].
   
curAuth == 1 ifTrue:[ ^ #read ].
^#none
%

category: 'Accessing Authorization'
method: Segment
ownerAuthorization

"Returns a Symbol that defines whether the Segment's owner is authorized to
 write (and read) in this Segment (#write), to read only (#read), or neither
 (#none)."

^ #( #none #read #write) at: ownerAuthorization + 1
%

category: 'Accessing Authorization'
method: Segment
worldAuthorization

"Returns a Symbol that defines whether all system users are authorized to write
 (and read) in this Segment (#write), to read only (#read), or neither
 (#none)."

^ #( #none #read #write) at: worldAuthorization + 1
%

category: 'Accessing Authorization'
method: Segment
groupsWithAuthorization: anAccessSymbol

"Returns an IdentitySet of group Strings of all groups with the authorization of
 anAccessSymbol (one of #write, #read, or #none) for the receiver."

| result |

( #( #write #read #none) includesValue: anAccessSymbol)
  ifFalse: [  ^ self _error: #segErrBadAuthKind args: #[anAccessSymbol] ].

result := IdentitySet new .
AllGroups valuesDo:[ :aGroup |
  (self authorizationForGroup: aGroup) == anAccessSymbol ifTrue:[
    result add: aGroup
    ].
  ].
^ result
%

! fixed 36635
category: 'Accessing Authorization'
method: Segment
usersWithAuthorization: anAccessSymbol

"Returns a IdentitySet containing all users with the authorization of
 anAccessSymbol (one of #write, #read, or #none) for the receiver."

| result |

( #( #write #read #none) includesValue: anAccessSymbol)
  ifFalse: [  ^ self _error: #segErrBadAuthKind args: #[anAccessSymbol] ].
   
result := IdentitySet new .
AllUsers do:[:aUserProfile |
  (self authorizationForUser: aUserProfile) == anAccessSymbol ifTrue:[
     result add: aUserProfile
     ].
  ].
^ result
%

category: 'Updating Authorization'
method: Segment
ownerAuthorization: anAuthorizationSymbol

"Redefines the authorization for the Segment's owner to one of the following
 authorization Symbols:

 * #write (the Segment's owner can both read and write in this Segment).

 * #read (read only).

 * #none (neither read nor write permission).

 Generates an error if anAuthorizationSymbol is not one of (#read, #write,
 #none).

 Requires the SegmentProtection privilege, if the segment is not owned
 by the GemStone UserProfile under which this session is running."

 | authInt |
 authInt := #( #none #read #write ) indexOfValue: anAuthorizationSymbol .
 authInt == 0 ifTrue:[ 
   ^ self _error: #segErrBadAuthKind args: #[anAuthorizationSymbol] 
   ].
 self _authAt: 5 put: (authInt - 1) 
%

category: 'Updating Authorization'
method: Segment
worldAuthorization: anAuthorizationSymbol

"Redefines the authorization for all users to one of the following
 authorization Symbols:

 * #write (all users can both read and write in this Segment).

 * #read (read only).

 * #none (neither read nor write permission).

 Generates an error if anAuthorizationSymbol is not one of (#read, #write,
 #none).

 Requires the SegmentProtection privilege, if the segment is not owned
 by the GemStone UserProfile under which this session is running."

 | authInt |
 authInt := #( #none #read #write ) indexOfValue: anAuthorizationSymbol .
 authInt == 0 ifTrue:[ 
   ^ self _error: #segErrBadAuthKind args: #[anAuthorizationSymbol] 
   ].
 self _authAt: 6 put: (authInt - 1) 
%

!  _authorizationChanged not used in Gs64 v2.2

category: 'Private'
method: Segment
_authAt: anOffset put: aValue

"offset   action 
 ------   ---------
  5       assign to ownerAuthorization instance variable
  6       assign to worldAuthorization instance variable
  3       add to groupsRead IdentitySet, create set if needed.
  4       add to groupsWrite IdentitySet, create set if needed.
 -3       remove from groupsRead IdentitySet
 -4       remove from groupsWrite IdentitySet
  7       assign new value to groupsRead (for repository conversion)
  8       assign new value to groupsWrite (for repository conversion)

  Gs64 v2.2 ,  offsets 7 and 8 not supported, was used by _migrateGroups.
"

<primitive: 292>
self _primitiveFailed: #_authAt:put: .
self _uncontinuableError
%

category: 'Execution'
classmethod: Segment
setCurrent: aSegment while: aBlock

| oldSeg result systm |

systm := System .
oldSeg := systm currentSegment.

"If the receiver is the current segment, just returns the evaluation of
 the block - doesn't need error handlers since the current segment won't
 be changed."
oldSeg == aSegment ifTrue: [ ^aBlock value ].

Exception category: nil number: nil do: [:ex:cat:num:args |
  (oldSeg == nil _or:[ oldSeg isKindOf: Segment]) ifTrue: [
    System currentSegment: oldSeg.
  ].
  ex resignal: cat number: num args: args.
  System currentSegment: aSegment.
].

systm currentSegment: aSegment .
[ 
  result := aBlock value 
] ensure:[
  System currentSegment: oldSeg
].
^result
%

category: 'Execution'
method: Segment
setCurrentWhile: aBlock

"Sets the receiver to be the current segment while the given block
 executes.  Catches all errors and reinstalls the current segment
 to avoid having the receiver be left as the current segment.  Returns
 the result of evaluating the zero-argument block."

^ self _class setCurrent: self while: aBlock
%

category: 'Backward Compatibility'
method: Segment
groupNo: groupIndex group: aGroupString authorization: anAuthorizationSymbol

"Obsolete in GemStone 4.1.  Use the group:authorization: method instead."

^ self group: aGroupString authorization: anAuthorizationSymbol
%

category: 'Updating Authorization'
method: Segment
group: aGroupString authorization: anAuthorizationSymbol

"Redefines the authorization for the specified group to one of the following
 authorization Symbols:

 * #write (members of the group can both read and write in this Segment).
 * #read (read only).
 * #none (neither read nor write permission).

 This method generates an error if aGroupString is not an element of
 the global object AllGroups, or if anAuthorizationSymbol is not one of (#read,
 #write, #none).

 Requires the SegmentProtection privilege, if the segment is not owned
 by the GemStone UserProfile under which this session is running."

| theGroup |

"Test for errInvalidAuthorization "
( #( #write #read #none) includesValue: anAuthorizationSymbol)
ifFalse: [  ^ self _error: #segErrBadAuthKind args: #[anAuthorizationSymbol] ].

"Get canonical group string from AllGroups."
theGroup := AllGroups _validateGroupString: aGroupString .
  
"modify the group collections for this segment as appropriate."
anAuthorizationSymbol == #write ifTrue:[ 
  self _authAt: -3 put: theGroup "readGroups remove: theGroup ifAbsent:[]" .
  self _authAt: 4 put: theGroup  "writeGroups _addSymbol: theGroup " .
  ]
ifFalse:[
  anAuthorizationSymbol == #read ifTrue:[
    self _authAt: -4 put: theGroup "writeGroups remove: theGroup ifAbsent:[]" .
    self _authAt: 3 put: theGroup  "readGroups _addSymbol: theGroup " .
    ]
  ifFalse:[ "none" 
    self _authAt: -3 put: theGroup "readGroups remove: theGroup ifAbsent:[]" .
    self _authAt: -4 put: theGroup "writeGroups remove: theGroup ifAbsent:[]" .
    ].
  ].
%

! nameOfGroupAt: deleted 

category: 'Private'
method: Segment
_currentUserAccess

"returns current user's access to objects in the receiver  ,
 0 == none,  1 == read , 2 == write
"
<primitive: 591>
self _primitiveFailed: #_currentUserAccess .
self _uncontinuableError
%


category: 'Accessing Authorization'
method: Segment
currentUserCanRead

"Returns true if the current user has read authorization for the
 receiver, false if not."

^ self _currentUserAccess >= 1
%

category: 'Accessing Authorization'
method: Segment
currentUserCanWrite

"Returns true if the current user has write authorization for the
 receiver, false if not."

^ self _currentUserAccess == 2
%

category: 'Storing and Loading'
method: Segment
writeTo: aPassiveObject

"Instances of Segment cannot be converted to passive form.  This method writes
 nil to aPassiveObject and stops GemStone Smalltalk execution with a notifier."

  aPassiveObject writeObject: nil.
  self _error: #rtErrAttemptToPassivateInvalidObject.
%

category: 'Repository Conversion'
method: Segment
_migrateGroups

"Converts the groups collections from SymbolSets to IdentitySets of Strings."

(Globals at:#DataCuratorSegment) setCurrentWhile:[
  groupsRead ~~ nil ifTrue:[
    self _authAt:7 put: (AllGroups _migrateSymbolSet: groupsRead ) .
  ].
  groupsWrite ~~ nil ifTrue:[
    self _authAt:8 put: (AllGroups _migrateSymbolSet: groupsWrite) .
  ].
].
%


! --------------- methods disallowed  are in segment2.gs


! _oldAuthorizationFor: deleted
! _migrate40to41  deleted

