492 lines
11 KiB
Smalltalk
492 lines
11 KiB
Smalltalk
"======================================================================
|
|
|
|
|
| Copyright (c) 2004-2009
|
|
| Ragnar Hojland Espinosa <ragnar@ragnar-hojland.com>,
|
|
|
|
|
| Contributions by:
|
|
| Göran Krampe
|
|
| Andreas Raab
|
|
|
|
|
| Ported by:
|
|
| Stephen Woolerton
|
|
|
|
|
| Permission is hereby granted, free of charge, to any person obtaining
|
|
| a copy of this software and associated documentation files (the
|
|
| 'Software'), to deal in the Software without restriction, including
|
|
| without limitation the rights to use, copy, modify, merge, publish,
|
|
| distribute, sublicense, and/or sell copies of the Software, and to
|
|
| permit persons to whom the Software is furnished to do so, subject to
|
|
| the following conditions:
|
|
|
|
|
| The above copyright notice and this permission notice shall be
|
|
| included in all copies or substantial portions of the Software.
|
|
|
|
|
| THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND,
|
|
| EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
| MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
|
| IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
|
| CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
|
| TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
|
| SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
|
|
|
|
======================================================================"
|
|
|
|
|
|
Object subclass: BERElement [
|
|
| length lengthLength value tagHeader tagLength |
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BERElement class >> elementClasses [
|
|
^
|
|
{BERInteger.
|
|
BEROctetString.
|
|
BERSequence.
|
|
BEREnumerated.
|
|
BERBoolean.
|
|
BERSet.
|
|
BERNull.
|
|
|
|
}
|
|
]
|
|
|
|
BERElement class >> identifyIncomingElement: firstByte [
|
|
"so why are we doing this in a comparision here, instead of asking the class wether it handles the element?"
|
|
|
|
| type |
|
|
type := self elementClasses
|
|
detect: [:each | each tagValue = firstByte asInteger]
|
|
ifNone: [nil].
|
|
^type
|
|
]
|
|
|
|
BERElement class >> new [
|
|
"this is here only to easily see who is using it down the heriarchy through the browser"
|
|
|
|
^self basicNew initialize
|
|
]
|
|
|
|
BERElement class >> newFrom: aStream [
|
|
| firstByte element elementClass |
|
|
firstByte := aStream next.
|
|
"Transcript show: '*** Next byte is: ', firstByte asString; cr."
|
|
elementClass := self identifyIncomingElement: firstByte.
|
|
elementClass ifNil:
|
|
[self error:
|
|
'invalid tag -- make sure class is in identifyIncomingElements: ', firstByte asString.].
|
|
element := elementClass new setTag: firstByte.
|
|
"we should read the tag here, instead of just the first byte"
|
|
element readLengthFrom: aStream.
|
|
element decode: aStream.
|
|
^element
|
|
]
|
|
|
|
BERElement class >> tagValue [
|
|
self subclassResponsibility
|
|
]
|
|
|
|
decode: aStream [
|
|
self subclassResponsibility
|
|
]
|
|
|
|
initialize [
|
|
tagHeader := 0
|
|
]
|
|
|
|
length [
|
|
^length
|
|
]
|
|
|
|
lengthLength [
|
|
^lengthLength
|
|
]
|
|
|
|
readLengthFrom: aStream [
|
|
| octets firstOctet |
|
|
firstOctet := aStream next asInteger.
|
|
firstOctet < 128
|
|
ifTrue:
|
|
["short definite length"
|
|
|
|
length := firstOctet.
|
|
lengthLength := 1]
|
|
ifFalse:
|
|
["long definite length"
|
|
|
|
octets := aStream next: (firstOctet bitXor: 128).
|
|
lengthLength := (firstOctet bitXor: 128) + 1. "the lengthlenghlength byte.. ugh."
|
|
length := octets contents inject: 0
|
|
into: [:injectedValue :each | (injectedValue bitShift: 8) + each asInteger]].
|
|
^length
|
|
]
|
|
|
|
setTag: aTag [
|
|
tagHeader := aTag.
|
|
tagLength := 1
|
|
]
|
|
|
|
tagLength [
|
|
^1
|
|
]
|
|
|
|
tagSetApplication [
|
|
tagHeader := tagHeader bitOr: 64
|
|
]
|
|
|
|
tagSetContext [
|
|
tagHeader := tagHeader bitOr: 128
|
|
]
|
|
|
|
totalLength [
|
|
^self length + self lengthLength + self tagLength
|
|
]
|
|
|
|
value [
|
|
^value
|
|
]
|
|
|
|
value: aValue [
|
|
value := aValue
|
|
]
|
|
|
|
writeBodyOn: aStream [
|
|
self subclassResponsibility
|
|
]
|
|
|
|
writeLength: aLength on: aStream [
|
|
| octets octetsIndex remainderValue netOctets |
|
|
octetsIndex := 1.
|
|
aLength < 128
|
|
ifTrue:
|
|
["short definite length"
|
|
|
|
aStream nextPut: (Character value: aLength)
|
|
|
|
"long definite length"]
|
|
ifFalse:
|
|
["why were we using value in this block, instead of aLength?"
|
|
|
|
octets := ByteArray new: (self intDigitLength: aLength) + 1.
|
|
remainderValue := aLength.
|
|
[remainderValue > 0] whileTrue:
|
|
[octets at: octetsIndex put: (remainderValue bitAnd: 255).
|
|
octetsIndex := octetsIndex + 1.
|
|
remainderValue := remainderValue bitShift: -8].
|
|
octets at: octetsIndex put: (octetsIndex - 1 bitOr: 128).
|
|
|
|
"hton"
|
|
netOctets := ByteArray new: octetsIndex.
|
|
(1 to: octetsIndex)
|
|
do: [:i | netOctets at: i put: (octets at: octetsIndex + 1 - i)].
|
|
aStream nextPutAll: netOctets asString].
|
|
^octetsIndex
|
|
]
|
|
|
|
writeOn: aStream [
|
|
aStream nextPut: (Character value: (self class tagValue bitOr: tagHeader)).
|
|
self writeBodyOn: aStream
|
|
]
|
|
|
|
writeOn: aStream withTag: aTag [
|
|
| combinedTag |
|
|
combinedTag := self class tagValue bitOr: tagHeader.
|
|
|
|
"here we are supposing that if we are given a tag, we dont need the universal tag value
|
|
im not really sure on wether its correct or not ."
|
|
|
|
"however, we are in .25 and its proved to be correct so far"
|
|
aTag ifNotNil:
|
|
[combinedTag := (combinedTag bitOr: 31) bitXor: 31.
|
|
combinedTag := combinedTag bitOr: aTag].
|
|
aStream nextPut: (Character value: combinedTag).
|
|
self writeBodyOn: aStream
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERElement subclass: BERBoolean [
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BERBoolean class >> tagValue [
|
|
^1
|
|
]
|
|
|
|
decode: aStream [
|
|
value := aStream next.
|
|
value := value > 0
|
|
]
|
|
|
|
writeBodyOn: aStream [
|
|
self writeLength: 1 on: aStream.
|
|
(value = 0 or: [value = false])
|
|
ifTrue: [aStream nextPut: (Character value: 0)]
|
|
ifFalse: [aStream nextPut: (Character value: 255)]
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERElement subclass: BERConstruct [
|
|
| elements |
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BERConstruct class >> new [
|
|
^self basicNew initialize
|
|
]
|
|
|
|
addElement: anElement [
|
|
self addElement: anElement withTag: nil
|
|
]
|
|
|
|
addElement: anElement withTag: aContextTag [
|
|
| taggedElement |
|
|
taggedElement := Association
|
|
new;
|
|
key: aContextTag value: anElement.
|
|
elements addLast: taggedElement
|
|
]
|
|
|
|
decode: aStream [
|
|
| elementLen part |
|
|
elementLen := self length.
|
|
[elementLen > 0] whileTrue:
|
|
[part := self class newFrom: aStream.
|
|
elementLen := elementLen - part totalLength.
|
|
self addElement: part]
|
|
]
|
|
|
|
elements [
|
|
^elements
|
|
]
|
|
|
|
initialize [
|
|
super initialize.
|
|
elements := OrderedCollection new
|
|
]
|
|
|
|
writeBodyOn: aStream [
|
|
| data dataStream |
|
|
data := Array new.
|
|
dataStream := WriteStream on: data.
|
|
elements
|
|
do: [:taggedElement | taggedElement value writeOn: dataStream withTag: taggedElement key].
|
|
|
|
"shouldnt we move this somewhere else?"
|
|
self writeLength: dataStream contents size on: aStream.
|
|
aStream nextPutAll: dataStream contents
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERElement subclass: BERInteger [
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BERInteger class >> tagValue [
|
|
^2
|
|
]
|
|
|
|
decode: aStream [
|
|
| highBitPos xorMask |
|
|
value := 0.
|
|
(1 to: length)
|
|
do: [:i | value := (value bitShift: 8) + aStream next asInteger].
|
|
|
|
"if the high bit is set, we have negative"
|
|
highBitPos := value highBit.
|
|
highBitPos = (length * 8)
|
|
ifTrue:
|
|
[xorMask := (1 bitShift: highBitPos) - 1.
|
|
value := value bitXor: xorMask.
|
|
value := (value + 1) negated]
|
|
]
|
|
|
|
intDigitLength: anInt [
|
|
"From Squeak: SmallInteger digitlength.
|
|
Called from BERInteger writeBodyOn: "
|
|
|
|
"Answer the number of indexable fields in the receiver. This value is the
|
|
same as the largest legal subscript. Included so that a SmallInteger can
|
|
behave like a LargePositiveInteger or LargeNegativeInteger."
|
|
|
|
(anInt < 16r100 and: [anInt > -16r100]) ifTrue: [^ 1].
|
|
(anInt < 16r10000 and: [anInt > -16r10000]) ifTrue: [^ 2].
|
|
(anInt < 16r1000000 and: [anInt > -16r1000000]) ifTrue: [^ 3].
|
|
^ 4
|
|
]
|
|
|
|
writeBodyOn: aStream [
|
|
| octets netOctets isNegative remainderValue octetsIndex |
|
|
isNegative := value < 0.
|
|
octets := ByteArray new: (self intDigitLength: value) + 2.
|
|
|
|
"put value into octet array, covert negatives as appropiate"
|
|
isNegative not
|
|
ifTrue:
|
|
[value = 0
|
|
ifTrue:
|
|
[octetsIndex := 1.
|
|
octets at: octetsIndex put: 0]
|
|
ifFalse:
|
|
[remainderValue := value.
|
|
octetsIndex := 0.
|
|
[remainderValue > 0] whileTrue:
|
|
[octetsIndex := octetsIndex + 1.
|
|
octets at: octetsIndex put: (remainderValue bitAnd: 255).
|
|
remainderValue := remainderValue bitShift: -8]]]
|
|
ifFalse:
|
|
["negatives are in two's complement -- to convert: 1. change to positive. 2. substract 1, 3. xor everythnig"
|
|
|
|
remainderValue := value negated.
|
|
remainderValue := remainderValue - 1.
|
|
octetsIndex := 0.
|
|
|
|
[octetsIndex := octetsIndex + 1.
|
|
octets at: octetsIndex put: ((remainderValue bitXor: 255) bitAnd: 255).
|
|
remainderValue := remainderValue bitShift: -8.
|
|
remainderValue > 0]
|
|
whileTrue].
|
|
|
|
"if originally we had a positive, and highest bit is set in the beginning of the array, we prefix the array with a zero byte"
|
|
"if said bit is set and original was negative, prefix with a all-ones byte"
|
|
"we actually test the end of the array because we are switching it around later for network order"
|
|
value > 0
|
|
ifTrue:
|
|
[((octets at: octetsIndex) bitAnd: 128) > 0
|
|
ifTrue:
|
|
[octetsIndex := octetsIndex + 1.
|
|
octets at: octetsIndex put: 0]].
|
|
value < 0
|
|
ifTrue:
|
|
[((octets at: octetsIndex) bitAnd: 128) = 0
|
|
ifTrue:
|
|
[octetsIndex := octetsIndex + 1.
|
|
octets at: octetsIndex put: 255]].
|
|
|
|
"hton"
|
|
netOctets := ByteArray new: octetsIndex.
|
|
(1 to: octetsIndex)
|
|
do: [:i | netOctets at: i put: (octets at: octetsIndex + 1 - i)].
|
|
self writeLength: octetsIndex on: aStream.
|
|
aStream nextPutAll: netOctets asString.
|
|
^octetsIndex
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERInteger subclass: BEREnumerated [
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BEREnumerated class >> tagValue [
|
|
^10
|
|
]
|
|
|
|
decode: aStream [
|
|
super decode: aStream
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERElement subclass: BERNull [
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BERNull class >> tagValue [
|
|
^5
|
|
]
|
|
|
|
decode: aStream [
|
|
"not sure about this.. should it be 0?"
|
|
|
|
"length := 1."
|
|
|
|
value := nil
|
|
]
|
|
|
|
writeBodyOn: aStream [
|
|
self writeLength: 0 on: aStream
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERElement subclass: BEROctetString [
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BEROctetString class >> tagValue [
|
|
^4
|
|
]
|
|
|
|
decode: aStream [
|
|
value := aStream next: length
|
|
]
|
|
|
|
writeBodyOn: aStream [
|
|
self writeLength: value size on: aStream.
|
|
aStream nextPutAll: value.
|
|
"theorically we should convert it to UTF8"
|
|
^value size
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERConstruct subclass: BERSequence [
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BERSequence class >> tagValue [
|
|
"SEQUENCE + Constructed"
|
|
|
|
^16 + 32
|
|
]
|
|
|
|
decode: aStream [
|
|
^super decode: aStream
|
|
]
|
|
]
|
|
|
|
|
|
|
|
|
|
BERConstruct subclass: BERSet [
|
|
|
|
<category: 'LDAP-BER'>
|
|
<comment: nil>
|
|
|
|
BERSet class >> tagValue [
|
|
"SET + Constructed"
|
|
|
|
^17 + 32
|
|
]
|
|
|
|
decode: aStream [
|
|
^super decode: aStream
|
|
]
|
|
]
|
|
|
|
|