#-----------------------------------------------------------------------------
# Copyright (C) 1999-2004 Jochen C. Loewer ([email protected])
#-----------------------------------------------------------------------------
#
# A (partial) LDAPv3 protocol implementation in plain Tcl.
#
# See RFC 2251 and ASN.1 (X.680) and BER (X.690).
#
#
# This software is copyrighted by Jochen C. Loewer ([email protected]). The
# following terms apply to all files associated with the software unless
# explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
#
# $Log: ldap.tcl,v $
# Revision 1.3 2004/09/24 06:54:24 andreas_kupries
# Scattered small fixes, mostly adding braces to unbraced
# expressions.
#
# Fixed problem with mismatched package names for the packages
# implementing the standard types.
#
# Revision 1.1 2004/04/27 19:45:35 andreas_kupries
#
# * installed_modules.tcl: Added new module.
# * examples/ldap:
# * modules/ldap: New module: LDAP client. Provided to us by Joechen
# Loewer <[email protected]>.
#
# * Added doctools documentation.
#
# Revision 1.1 2000/03/23 17:40:22 17:40:22 jolo (Jochen Loewer)
# Initial revision
#
#
# written by Jochen Loewer
# 3 June, 1999
#
#-----------------------------------------------------------------------------
package provide ldap 1.2
namespace eval ldap {
namespace export connect secure_connect \
disconnect \
bind unbind \
search \
modify \
add \
delete \
modifyDN
variable SSLCertifiedAuthoritiesFile
variable doDebug
set doDebug 0
array set resultCode2String {
0 success
1 operationsError
2 protocolError
3 timeLimitExceeded
4 sizeLimitExceeded
5 compareFalse
6 compareTrue
7 authMethodNotSupported
8 strongAuthRequired
10 referral
11 adminLimitExceeded
12 unavailableCriticalExtension
13 confidentialityRequired
14 saslBindInProgress
16 noSuchAttribute
17 undefinedAttributeType
18 inappropriateMatching
19 constraintViolation
20 attributeOrValueExists
21 invalidAttributeSyntax
32 noSuchObject
33 aliasProblem
34 invalidDNSyntax
35 isLeaf
36 aliasDereferencingProblem
48 inappropriateAuthentication
49 invalidCredentials
50 insufficientAccessRights
51 busy
52 unavailable
53 unwillingToPerform
54 loopDetect
64 namingViolation
65 objectClassViolation
66 notAllowedOnNonLeaf
67 notAllowedOnRDN
68 entryAlreadyExists
69 objectClassModsProhibited
80 other
}
}
#-----------------------------------------------------------------------------
# connect
#
#-----------------------------------------------------------------------------
proc ldap::connect { host {port 389} } {
#--------------------------------------
# connect via TCP/IP
#--------------------------------------
set sock [socket $host $port]
fconfigure $sock -blocking yes -translation binary
#--------------------------------------
# initialize connection array
#--------------------------------------
upvar ::ldap::ldap$sock conn
catch { unset conn }
set conn(sock) $sock
set conn(messageId) 0
return ::ldap::ldap$sock
}
#-----------------------------------------------------------------------------
# secure_connect
#
#-----------------------------------------------------------------------------
proc ldap::secure_connect { host {port 636} } {
variable SSLCertifiedAuthoritiesFile
package require tls
#------------------------------------------------------------------
# connect via TCP/IP
#------------------------------------------------------------------
set sock [socket $host $port]
fconfigure $sock -blocking yes -translation binary
#------------------------------------------------------------------
# make it a SSL connection
#
#------------------------------------------------------------------
#tls::import $sock -cafile $SSLCertifiedAuthoritiesFile -ssl2 no -ssl3 yes -tls1 yes
tls::import $sock -cafile "" -certfile "" -keyfile "" \
-request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes
set retry 0
while {1} {
if {$retry > 20} {
close $sock
return -code error "too long retry to setup SSL connection"
}
if {[catch { tls::handshake $sock } err]} {
if {[string match "*resource temporarily unavailable*" $err]} {
after 50
incr retry
} else {
close $sock
return -code error $err
}
} else {
break
}
}
#puts stderr [tls::status $sock]
#--------------------------------------
# initialize connection array
#--------------------------------------
upvar ::ldap::ldap$sock conn
catch { unset conn }
set conn(sock) $sock
set conn(messageId) 0
return ::ldap::ldap$sock
}
#-----------------------------------------------------------------------------
# bind - does a bind with simple authentication
#
#-----------------------------------------------------------------------------
proc ldap::bind { handle {name ""} {password ""} } {
upvar $handle conn
incr conn(messageId)
#-----------------------------------------------------------------
# marshal bind request packet and send it
#
#-----------------------------------------------------------------
set request [asnSequence \
[asnInteger $conn(messageId)] \
[asnApplicationConstr 0 \
[asnInteger 3] \
[asnOctetString $name] \
[asnChoice 0 $password] \
] \
]
debugData bindRequest $request
puts -nonewline $conn(sock) $request
flush $conn(sock)
#-----------------------------------------------------------------
# receive (blocking) bind response packet(s) and unmarshal it
#
#-----------------------------------------------------------------
asnGetResponse $conn(sock) response
debugData bindResponse $response
asnGetSequence response response
asnGetInteger response MessageID
if { $MessageID != $conn(messageId) } {
error "umatching response packet ($MessageID != $conn(messageId))"
}
asnGetApplication response appNum
if { $appNum != 1 } {
error "unexpected application number ($appNum != 1)"
}
asnGetEnumeration response resultCode
asnGetOctetString response matchedDN
asnGetOctetString response errorMessage
if {$resultCode != 0} {
return -code error "LDAP error $ldap::resultCode2String($resultCode) '$matchedDN': $errorMessage"
}
}
#-----------------------------------------------------------------------------
# unbind
#
#-----------------------------------------------------------------------------
proc ldap::unbind { handle } {
upvar $handle conn
incr conn(messageId)
#------------------------------------------------
# marshal unbind request packet and send it
#------------------------------------------------
set request [asnSequence \
[asnInteger $conn(messageId)] \
[asnApplication 2 ""] ]
debugData unbindRequest $request
puts -nonewline $conn(sock) $request
flush $conn(sock)
}
#-----------------------------------------------------------------------------
# buildUpFilter - parses the text representation of LDAP search
# filters and transforms it into the correct
# marshalled representation for the search request
# packet
#
#-----------------------------------------------------------------------------
proc ldap::buildUpFilter { filter } {
set first [lindex $filter 0]
set data ""
switch -regexp -- $first {
^\\&$ { #--- and -------------------------------------------
foreach term [lrange $filter 1 end] {
append data [buildUpFilter $term]
}
return [asnChoiceConstr 0 $data]
}
^\\|$ { #--- or --------------------------------------------
foreach term [lrange $filter 1 end] {
append data [buildUpFilter $term]
}
return [asnChoiceConstr 1 $data]
}
^\\!$ { #--- not -------------------------------------------
return [asnChoiceConstr 2 [buildUpFilter [lindex $filter 1]]]
}
=\\*$ { #--- present ---------------------------------------
set endpos [expr {[string length $first] -3}]
set attributetype [string range $first 0 $endpos]
return [asnChoice 7 $attributetype]
}
^[0-9A-z.]*~= { #--- approxMatch --------------------------
regexp {^([0-9A-z.]*)~=(.*)$} $first all attributetype value
return [asnChoiceConstr 8 [asnOctetString $attributetype] \
[asnOctetString $value] ]
}
^[0-9A-z.]*<= { #--- lessOrEqual --------------------------
regexp {^([0-9A-z.]*)<=(.*)$} $first all attributetype value
return [asnChoiceConstr 6 [asnOctetString $attributetype] \
[asnOctetString $value] ]
}
^[0-9A-z.]*>= { #--- greaterOrEqual -----------------------
regexp {^([0-9A-z.]*)>=(.*)$} $first all attributetype value
return [asnChoiceConstr 5 [asnOctetString $attributetype] \
[asnOctetString $value] ]
}
^[0-9A-z.]*=\\*[^*]*\\* { #--- substrings (any) -----------------
regexp {^([0-9A-z.]*)=\*(.*)\*$} $first all attributetype value
trace "any substrings: attributetype='$attributetype' value='$value'"
return [asnChoiceConstr 4 [asnOctetString $attributetype] \
[asnSequence [asnChoice 1 $value] ] ]
}
^[0-9A-z.]*=[^*]*\\*$ { #--- substrings (initial) -------------------
regexp {^([0-9A-z.]*)=(.*)\*$} $first all attributetype value
trace "initial substrings: attributetype='$attributetype' value='$value'"
return [asnChoiceConstr 4 [asnOctetString $attributetype] \
[asnSequence [asnChoice 0 $value] ] ]
}
^[0-9A-z.]*=\\*[^*]*$ { #--- substrings (final) -----------------
regexp {^([0-9A-z.]*)=\*(.*)$} $first all attributetype value
trace "final substrings: attributetype='$attributetype' value='$value'"
return [asnChoiceConstr 4 [asnOctetString $attributetype] \
[asnSequence [asnChoice 2 $value] ] ]
}
^[0-9A-z.]*= { #--- equal ---------------------------------
regexp {^([0-9A-z.]*)=(.*)$} $first all attributetype value
trace "equal: attributetype='$attributetype' value='$value'"
return [asnChoiceConstr 3 [asnOctetString $attributetype] \
[asnOctetString $value] ]
}
default {
return [buildUpFilter $first]
#error "cant handle $first for filter part"
}
}
}
#-----------------------------------------------------------------------------
# search - performs a LDAP search below the baseObject tree using a
# complex LDAP search expression (like "|(cn=Linus*)(sn=Torvalds*)"
# and returns all matching objects (DNs) with given attributes
# (or all attributes if empty list is given) as list:
#
# dn1 { attr1 val1 attr2 val2 ... } dn2 { a1 v1 } ....
#
#-----------------------------------------------------------------------------
proc ldap::search { handle baseObject filterString attributes } {
upvar $handle conn
set scope 2
set derefAliases 0
set sizeLimit 0
set timeLimit 0
set attrsOnly 0
#----------------------------------------------------------
# marshal filter and attributes parameter
#----------------------------------------------------------
regsub -all {\(} $filterString " \{" filterString
regsub -all {\)} $filterString "\} " filterString
set berFilter [buildUpFilter $filterString]
set berAttributes ""
foreach attribute $attributes {
append berAttributes [asnOctetString $attribute]
}
#----------------------------------------------------------
# marshal search request packet and send it
#----------------------------------------------------------
incr conn(messageId)
set request [asnSequence \
[asnInteger $conn(messageId)] \
[asnApplicationConstr 3 \
[asnOctetString $baseObject] \
[asnEnumeration $scope] \
[asnEnumeration $derefAliases] \
[asnInteger $sizeLimit] \
[asnInteger $timeLimit] \
[asnBoolean $attrsOnly] \
$berFilter \
[asnSequence $berAttributes] \
] \
]
debugData searchRequest $request
puts -nonewline $conn(sock) $request
flush $conn(sock)
#----------------------------------------------------------
# receive (blocking) search response packet(s)
#----------------------------------------------------------
set results {}
set lastPacket 0
while { !$lastPacket } {
asnGetResponse $conn(sock) response
debugData searchResponse $response
asnGetSequence response response
asnGetInteger response MessageID
if { $MessageID != $conn(messageId) } {
error "umatching response packet ($MessageID != $conn(messageId))"
}
asnGetApplication response appNum
if { ($appNum != 4) && ($appNum != 5) } {
error "unexpected application number ($appNum != 4 or 5)"
}
if {$appNum == 4} {
#----------------------------------------------------------
# unmarshal search data packet
#----------------------------------------------------------
asnGetOctetString response objectName
asnGetSequence response attributes
set result_attributes {}
while { [string length $attributes] != 0 } {
asnGetSequence attributes attribute
asnGetOctetString attribute attrType
asnGetSet attribute attrValues
set result_attrValues {}
while { [string length $attrValues] != 0 } {
asnGetOctetString attrValues attrValue
lappend result_attrValues $attrValue
}
lappend result_attributes $attrType $result_attrValues
}
lappend results [list $objectName $result_attributes]
}
if {$appNum == 5} {
#----------------------------------------------------------
# unmarshal search final response packet
#----------------------------------------------------------
asnGetEnumeration response resultCode
asnGetOctetString response matchedDN
asnGetOctetString response errorMessage
if {$resultCode != 0} {
return -code error "LDAP error $ldap::resultCode2String($resultCode): $errorMessage"
}
set lastPacket 1
}
}
return $results
}
#-----------------------------------------------------------------------------
# modify - provides attribute modifications on one single object (DN):
# o replace attributes with new values
# o delete attributes (having certain values)
# o add attributes with new values
#
#-----------------------------------------------------------------------------
proc ldap::modify { handle dn
attrValToReplace { attrToDelete {} } { attrValToAdd {} } } {
upvar $handle conn
set operationAdd 0
set operationDelete 1
set operationReplace 2
#------------------------------------------------------------------
# marshal attribute modify operations
# - always mode 'replace' ! see rfc2251:
#
# replace: replace all existing values of the given attribute
# with the new values listed, creating the attribute if it
# did not already exist. A replace with no value will delete
# the entire attribute if it exists, and is ignored if the
# attribute does not exist.
#
#------------------------------------------------------------------
set modifications {}
foreach { attrName attrValue } $attrValToReplace {
append modifications [asnSequence \
[asnEnumeration $operationReplace ] \
[asnSequence \
[asnOctetString $attrName ] \
[asnSet \
[asnOctetString $attrValue ] \
] \
] \
]
}
#------------------------------------------------------------------
# marshal attribute add operations
#
#------------------------------------------------------------------
foreach { attrName attrValue } $attrValToAdd {
append modifications [asnSequence \
[asnEnumeration $operationAdd ] \
[asnSequence \
[asnOctetString $attrName ] \
[asnSet \
[asnOctetString $attrValue ] \
] \
] \
]
}
#------------------------------------------------------------------
# marshal attribute delete operations
#
# - a non-empty value will trigger to delete only those
# attributes which have the same value as the given one
#
# - an empty value will trigger to delete the attribute
# in all cases
#
#------------------------------------------------------------------
foreach { attrName attrValue } $attrToDelete {
if {$attrValue == ""} {
set val [asnSet ""]
} else {
set val [asnSet [asnOctetString $attrValue]]
}
append modifications [asnSequence \
[asnEnumeration $operationDelete ] \
[asnSequence \
[asnOctetString $attrName ] \
$val \
] \
]
}
#----------------------------------------------------------
# marshal 'modify' request packet and send it
#----------------------------------------------------------
incr conn(messageId)
set request [asnSequence \
[asnInteger $conn(messageId)] \
[asnApplicationConstr 6 \
[asnOctetString $dn ] \
[asnSequence $modifications ] \
] \
]
debugData modifyRequest $request
puts -nonewline $conn(sock) $request
flush $conn(sock)
#-----------------------------------------------------------------------
# receive (blocking) 'modify' response packet(s) and unmarshal it
#-----------------------------------------------------------------------
asnGetResponse $conn(sock) response
debugData bindResponse $response
asnGetSequence response response
asnGetInteger response MessageID
if { $MessageID != $conn(messageId) } {
error "umatching response packet ($MessageID != $conn(messageId))"
}
asnGetApplication response appNum
if { $appNum != 7 } {
error "unexpected application number ($appNum != 7)"
}
asnGetEnumeration response resultCode
asnGetOctetString response matchedDN
asnGetOctetString response errorMessage
if {$resultCode != 0} {
return -code error "LDAP error $ldap::resultCode2String($resultCode) $matchedDN: $errorMessage"
}
}
#-----------------------------------------------------------------------------
# add - will create a new object using given DN and sets the given
# attributes
#
#-----------------------------------------------------------------------------
proc ldap::add { handle dn attrValueTuples } {
upvar $handle conn
#------------------------------------------------------------------
# marshal attribute list
#
#------------------------------------------------------------------
set attrList ""
foreach { attrName attrValue } $attrValueTuples {
append attrList [asnSequence \
[asnOctetString $attrName ] \
[asnSet \
[asnOctetString $attrValue ] \
] \
]
}
#----------------------------------------------------------
# marshal search 'add' request packet and send it
#----------------------------------------------------------
incr conn(messageId)
set request [asnSequence \
[asnInteger $conn(messageId)] \
[asnApplicationConstr 8 \
[asnOctetString $dn ] \
[asnSequence $attrList ] \
] \
]
debugData addRequest $request
puts -nonewline $conn(sock) $request
flush $conn(sock)
#-----------------------------------------------------------------------
# receive (blocking) 'add' response packet(s) and unmarshal it
#
#-----------------------------------------------------------------------
asnGetResponse $conn(sock) response
debugData bindResponse $response
asnGetSequence response response
asnGetInteger response MessageID
if { $MessageID != $conn(messageId) } {
error "umatching response packet ($MessageID != $conn(messageId))"
}
asnGetApplication response appNum
if { $appNum != 9 } {
error "unexpected application number ($appNum != 9)"
}
asnGetEnumeration response resultCode
asnGetOctetString response matchedDN
asnGetOctetString response errorMessage
if {$resultCode != 0} {
return -code error "LDAP error $ldap::resultCode2String($resultCode) $matchedDN: $errorMessage"
}
}
#-----------------------------------------------------------------------------
# delete - removes the whole object (DN) inclusive all attributes
#
#-----------------------------------------------------------------------------
proc ldap::delete { handle dn } {
upvar $handle conn
#----------------------------------------------------------
# marshal 'delete' request packet and send it
#----------------------------------------------------------
incr conn(messageId)
set request [asnSequence \
[asnInteger $conn(messageId)] \
[asnApplication 10 $dn ] \
]
debugData deleteRequest $request
puts -nonewline $conn(sock) $request
flush $conn(sock)
#-----------------------------------------------------------------------
# receive (blocking) 'delete' response packet(s) and unmarshal it
#
#-----------------------------------------------------------------------
asnGetResponse $conn(sock) response
debugData bindResponse $response
asnGetSequence response response
asnGetInteger response MessageID
if { $MessageID != $conn(messageId) } {
error "umatching response packet ($MessageID != $conn(messageId))"
}
asnGetApplication response appNum
if { $appNum != 11 } {
error "unexpected application number ($appNum != 11)"
}
asnGetEnumeration response resultCode
asnGetOctetString response matchedDN
asnGetOctetString response errorMessage
if {$resultCode != 0} {
return -code error "LDAP error $ldap::resultCode2String($resultCode) $matchedDN: $errorMessage"
}
}
#-----------------------------------------------------------------------------
# modifyDN - moves an object (DN) to another (relative) place
#
#-----------------------------------------------------------------------------
proc ldap::modifyDN { handle dn newrdn { deleteOld 1 } } {
upvar $handle conn
#----------------------------------------------------------
# marshal 'modifyDN' request packet and send it
#----------------------------------------------------------
incr conn(messageId)
set request [asnSequence \
[asnInteger $conn(messageId)] \
[asnApplicationConstr 12 \
[asnOctetString $dn ] \
[asnOctetString $newrdn ] \
[asnBoolean $deleteOld ] \
] \
]
debugData modifyRequest $request
puts -nonewline $conn(sock) $request
flush $conn(sock)
#-----------------------------------------------------------------------
# receive (blocking) 'modifyDN' response packet(s) and unmarshal it
#-----------------------------------------------------------------------
asnGetResponse $conn(sock) response
debugData bindResponse $response
asnGetSequence response response
asnGetInteger response MessageID
if { $MessageID != $conn(messageId) } {
error "umatching response packet ($MessageID != $conn(messageId))"
}
asnGetApplication response appNum
if { $appNum != 13 } {
error "unexpected application number ($appNum != 13)"
}
asnGetEnumeration response resultCode
asnGetOctetString response matchedDN
asnGetOctetString response errorMessage
if {$resultCode != 0} {
return -code error "LDAP error $ldap::resultCode2String($resultCode) $matchedDN: $errorMessage"
}
}
#-----------------------------------------------------------------------------
# disconnect
#
#-----------------------------------------------------------------------------
proc ldap::disconnect { handle } {
upvar $handle conn
# should we sent an 'unbind' ?
close $conn(sock)
unset conn
return
}
#-----------------------------------------------------------------------------
# trace
#
#-----------------------------------------------------------------------------
proc ldap::trace { message } {
variable doDebug
if {!$doDebug} return
puts stderr $message
}
#-----------------------------------------------------------------------------
# debugData
#
#-----------------------------------------------------------------------------
proc ldap::debugData { info data } {
variable doDebug
if {!$doDebug} return
set len [string length $data]
trace "$info ($len bytes):"
set address ""
set hexnums ""
set ascii ""
for {set i 0} {$i < $len} {incr i} {
set v [string index $data $i]
binary scan $v H2 hex
binary scan $v c num
set num [expr {( $num + 0x100 ) % 0x100}]
set text .
if {$num > 31} {
set text $v
}
if { ($i % 16) == 0 } {
if {$address != ""} {
trace [format "%4s %-48s |%s|" $address $hexnums $ascii ]
set address ""
set hexnums ""
set ascii ""
}
append address [format "%04d" $i]
}
append hexnums "$hex "
append ascii $text
#trace [format "%3d %2s %s" $i $hex $text]
}
if {$address != ""} {
trace [format "%4s %-48s |%s|" $address $hexnums $ascii ]
}
trace ""
}
#-----------------------------------------------------------------------------
# asnLength
#
#-----------------------------------------------------------------------------
proc ldap::asnLength { len } {
if {$len < 128} {
return [binary format c $len]
}
if {$len < 65536} {
return [binary format H2S 82 $len]
}
return [binary format H2I 84 $len]
}
#-----------------------------------------------------------------------------
# asnSequence
#
#-----------------------------------------------------------------------------
proc ldap::asnSequence { args } {
set out ""
foreach part $args {
append out $part
}
set len [string length $out]
return [binary format H2a*a$len 30 [asnLength $len] $out]
}
#-----------------------------------------------------------------------------
# asnSet
#
#-----------------------------------------------------------------------------
proc ldap::asnSet { args } {
set out ""
foreach part $args {
append out $part
}
set len [string length $out]
return [binary format H2a*a$len 31 [asnLength $len] $out]
}
#-----------------------------------------------------------------------------
# asnApplicationConstr
#
#-----------------------------------------------------------------------------
proc ldap::asnApplicationConstr { appNumber args } {
set out ""
foreach part $args {
append out $part
}
set code [expr {0x060 + $appNumber}]
set len [string length $out]
return [binary format ca*a$len $code [asnLength $len] $out]
}
#-----------------------------------------------------------------------------
# asnApplication
#
#-----------------------------------------------------------------------------
proc ldap::asnApplication { appNumber data } {
set code [expr {0x040 + $appNumber}]
set len [string length $data]
return [binary format ca*a$len $code [asnLength $len] $data]
}
#-----------------------------------------------------------------------------
# asnChoice
#
#-----------------------------------------------------------------------------
proc ldap::asnChoice { appNumber args } {
set out ""
foreach part $args {
append out $part
}
set code [expr {0x080 + $appNumber}]
set len [string length $out]
return [binary format ca*a$len $code [asnLength $len] $out]
}
#-----------------------------------------------------------------------------
# asnChoiceConstr
#
#-----------------------------------------------------------------------------
proc ldap::asnChoiceConstr { appNumber args } {
set out ""
foreach part $args {
append out $part
}
set code [expr {0x0A0 + $appNumber}]
set len [string length $out]
return [binary format ca*a$len $code [asnLength $len] $out]
}
#-----------------------------------------------------------------------------
# asnInteger
#
#-----------------------------------------------------------------------------
proc ldap::asnInteger { number } {
if {($number >= -128) && ($number < 128)} {
return [binary format H2H2c 02 01 $number]
}
if {($number >= -32768) && ($number < 32767)} {
return [binary format H2H2S 02 02 $number]
}
return [binary format H2H2I 02 04 $number]
}
#-----------------------------------------------------------------------------
# asnEnumeration
#
#-----------------------------------------------------------------------------
proc ldap::asnEnumeration { number } {
if {($number >= -128) && ($number < 128)} {
return [binary format H2H2c 0a 01 $number]
}
if {($number >= -32768) && ($number < 32767)} {
return [binary format H2H2S 0a 02 $number]
}
return [binary format H2H2I 0a 04 $number]
}
#-----------------------------------------------------------------------------
# asnBoolean
#
#-----------------------------------------------------------------------------
proc ldap::asnBoolean { bool } {
return [binary format H2H2c 01 01 [expr {$bool ? 0x0FF : 0}]]
}
#-----------------------------------------------------------------------------
# asnOctetString
#
#-----------------------------------------------------------------------------
proc ldap::asnOctetString { string } {
set len [string length $string]
return [binary format H2a*a$len 04 [asnLength $len] $string]
}
#-----------------------------------------------------------------------------
# asnGetResponse - LDAP specific ?
#
#-----------------------------------------------------------------------------
proc ldap::asnGetResponse { sock data_var } {
upvar $data_var data
set tag [read $sock 1]
if {$tag == "\x30"} {
set len1 [read $sock 1]
binary scan $len1 c num
set length [expr {($num + 0x100) % 0x100}]
trace "asnGetResponse length=$length"
if {$length >= 0x080} {
set len_length [expr {$length & 0x7f}]
set lengthBytes [read $sock $len_length]
switch $len_length {
1 { binary scan $lengthBytes c length
set length [expr {($length + 0x100) % 0x100}]
}
2 { binary scan $lengthBytes S length }
3 { binary scan \x00$lengthBytes I length }
4 { binary scan $lengthBytes I length }
default {
error "length information too long ($len_length)"
}
}
}
set rest [read $sock $length]
set data [binary format aa*a$length $tag [asnLength $length] $rest]
} else {
set tag_hex ""
binary scan $tag H2 tag_hex
error "unknown start tag [string length $tag] $tag_hex"
}
}
#-----------------------------------------------------------------------------
# asnGetByte
#
#-----------------------------------------------------------------------------
proc ldap::asnGetByte { data_var byte_var } {
upvar $data_var data $byte_var byte
binary scan [string index $data 0] c byte
set byte [expr {($byte + 0x100) % 0x100}]
set data [string range $data 1 end]
trace "asnGetByte $byte"
}
#-----------------------------------------------------------------------------
# asnGetBytes
#
#-----------------------------------------------------------------------------
proc ldap::asnGetBytes { data_var length bytes_var } {
upvar $data_var data $bytes_var bytes
incr length -1
set bytes [string range $data 0 $length]
incr length
set data [string range $data $length end]
debugData asnGetBytes $bytes
}
#-----------------------------------------------------------------------------
# asnGetLength
#
#-----------------------------------------------------------------------------
proc ldap::asnGetLength { data_var length_var } {
upvar $data_var data $length_var length
asnGetByte data length
if {$length >= 0x080} {
set len_length [expr {$length & 0x7f}]
asnGetBytes data $len_length lengthBytes
switch $len_length {
1 { binary scan $lengthBytes c length
set length [expr {($length + 0x100) % 0x100}]
}
2 { binary scan $lengthBytes S length }
3 { binary scan \x00$lengthBytes I length }
4 { binary scan $lengthBytes I length }
default {
error "length information too long"
}
}
}
trace "asnGetLength -> length = $length"
}
#-----------------------------------------------------------------------------
# asnGetInteger
#
#-----------------------------------------------------------------------------
proc ldap::asnGetInteger { data_var int_var } {
upvar $data_var data $int_var int
asnGetByte data tag
asnGetLength data len
asnGetBytes data $len integerBytes
if {$tag != 0x02} {
error "Expected Integer, but got $tag"
}
set int ?
trace "asnGetInteger len=$len"
switch $len {
1 { binary scan $integerBytes c int }
2 { binary scan $integerBytes S int }
3 { binary scan \x00$integerBytes I int }
4 { binary scan $integerBytes I int }
default {
error "length information too long"
}
}
trace "asnGetInteger int=$int"
}
#-----------------------------------------------------------------------------
# asnGetEnumeration
#
#-----------------------------------------------------------------------------
proc ldap::asnGetEnumeration { data_var enum_var } {
upvar $data_var data $enum_var enum
asnGetByte data tag
asnGetLength data len
asnGetBytes data $len integerBytes
if {$tag != 0x0a} {
error "Expected Enumeration, but got $tag"
}
set enum ?
trace "asnGetEnumeration len=$len"
switch $len {
1 { binary scan $integerBytes c enum }
2 { binary scan $integerBytes S enum }
3 { binary scan \x00$integerBytes I enum }
4 { binary scan $integerBytes I enum }
default {
error "length information too long"
}
}
trace "asnGetEnumeration enum=$enum"
}
#-----------------------------------------------------------------------------
# asnGetOctetString
#
#-----------------------------------------------------------------------------
proc ldap::asnGetOctetString { data_var string_var } {
upvar $data_var data $string_var string
asnGetByte data byte
if {$byte != 0x04} {
error "Got different tag than octet string (0x04)"
}
asnGetLength data length
asnGetBytes data $length temp
set string $temp
}
#-----------------------------------------------------------------------------
# asnGetSequence
#
#-----------------------------------------------------------------------------
proc ldap::asnGetSequence { data_var sequence_var } {
upvar $data_var data $sequence_var sequence
asnGetByte data byte
if {$byte != 0x030} {
error "Got different tag than sequence (0x030)"
}
asnGetLength data length
asnGetBytes data $length temp
set sequence $temp
}
#-----------------------------------------------------------------------------
# asnGetSet
#
#-----------------------------------------------------------------------------
proc ldap::asnGetSet { data_var set_var } {
upvar $data_var data $set_var set
asnGetByte data byte
if {$byte != 0x031} {
error "Got different tag than set (0x031)"
}
asnGetLength data length
asnGetBytes data $length temp
set set $temp
}
#-----------------------------------------------------------------------------
# asnGetApplication
#
#-----------------------------------------------------------------------------
proc ldap::asnGetApplication { data_var appNumber_var } {
upvar $data_var data $appNumber_var appNumber
asnGetByte data byte
asnGetLength data length
if {($byte & 0xE0) != 0x060} {
error "Got different tag than application (0x060)"
}
set appNumber [expr {$byte & 0x1F}]
}
