A try to fix automatic memory handling for LDAP structures.
- free ldap-messages of type result - free ldap-messages of type entry if and only if ldap_first_entry() converted from a result into an entry - don't free ldap-messages of type entry - entries depend on results, so don't free result before entries derived from it
This commit is contained in:
eknauel
parent
55f238280a
commit
e236fbaec4
|
|
@ -72,6 +72,8 @@
|
|||
ldap-message-c-pointer
|
||||
ldap-message-session
|
||||
set-ldap-message-session!
|
||||
ldap-message-result
|
||||
set-ldap-message-result!
|
||||
ldap-modification-c-pointer
|
||||
ldap-api-info-c-pointer
|
||||
ber-element-c-pointer
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@
|
|||
(display (number->string (ldap-message-c-pointer x) 16)))
|
||||
((ber-element? x)
|
||||
(display (number->string (ber-element-c-pointer x) 16)))
|
||||
((ldap-session? x)
|
||||
(display (number->string (ldap-session-c-pointer x) 16)))
|
||||
(else
|
||||
(display x))))
|
||||
lst)
|
||||
|
|
@ -29,10 +31,11 @@
|
|||
"scsh_ldap_memfree")
|
||||
|
||||
(define (ldap-session-finalizer session)
|
||||
(ddisplay "Finalizing session" (ldap-session-c-pointer session))
|
||||
(ddisplay "FREE ldap-session " session)
|
||||
(if (ldap-session-bound? session)
|
||||
(if (not (ldap-session-implicit-unbind-ok? session))
|
||||
(raise (condition (&ldap-implicit-unbind (session session))))
|
||||
(raise (condition
|
||||
(&ldap-implicit-unbind (code #f) (session session))))
|
||||
(if (ldap-session-auto-unbind? session)
|
||||
(ldap-unbind session))))
|
||||
(remove-from-weak-table! *object-table* (ldap-session-c-pointer session))
|
||||
|
|
@ -93,7 +96,8 @@
|
|||
server-controls client-controls
|
||||
credentials)
|
||||
(raise (condition (&ldap-bindings-not-implemented
|
||||
(what '(ldap-sasl-bind ldap-controls))))))
|
||||
(what '(ldap-sasl-bind ldap-controls))
|
||||
(session #f) (code #f)))))
|
||||
|
||||
;;; UNBIND_S
|
||||
|
||||
|
|
@ -124,12 +128,12 @@
|
|||
"scsh_ldap_msgfree")
|
||||
|
||||
(define (ldap-message-unregister-object message)
|
||||
(ddisplay "Message unregistering finalizer " (ldap-message-c-pointer message))
|
||||
(ddisplay "UNREGISTER ldap-message " message)
|
||||
(remove-from-weak-table! *object-table*
|
||||
(ldap-message-c-pointer message)))
|
||||
|
||||
(define (ldap-message-freeing-finalizer message)
|
||||
(ddisplay "Message freeing finalizer " (ldap-message-c-pointer message))
|
||||
(ddisplay "FREE ldap-message " message)
|
||||
(ldap-message-unregister-object message)
|
||||
(ldap-msgfree message))
|
||||
|
||||
|
|
@ -166,6 +170,7 @@
|
|||
(ddisplay "ldap-search new object " message)
|
||||
(add-to-weak-table! *object-table* pointer message)
|
||||
(set-ldap-message-session! message session)
|
||||
(set-ldap-message-result! message #f)
|
||||
(add-finalizer! message ldap-message-freeing-finalizer)
|
||||
message)))
|
||||
(raise-ldap-condition ret-obj session))))))))
|
||||
|
|
@ -187,7 +192,8 @@
|
|||
(if call-successful?
|
||||
result
|
||||
(raise
|
||||
(condition (&ldap-session-option-error (session session)))))))))
|
||||
(condition (&ldap-session-option-error
|
||||
(code #f) (session session)))))))))
|
||||
|
||||
(define (ldap-session-option session-option . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
|
|
@ -200,7 +206,8 @@
|
|||
(if call-successful?
|
||||
result
|
||||
(raise
|
||||
(condition (&ldap-session-option-error (session session)))))))))
|
||||
(condition (&ldap-session-option-error
|
||||
(code #f) (session session)))))))))
|
||||
|
||||
;;;
|
||||
|
||||
|
|
@ -306,10 +313,9 @@
|
|||
"scsh_ldap_ber_free")
|
||||
|
||||
(define (ber-element-finalizer ber-element)
|
||||
(ddisplay "FREE ber-element " ber-element)
|
||||
(remove-from-weak-table!
|
||||
*object-table* (ber-element-c-pointer ber-element))
|
||||
(ddisplay "Freeing BerElement "
|
||||
(ber-element-c-pointer ber-element))
|
||||
(ber-element-free ber-element 1))
|
||||
|
||||
(define (ldap-first-attribute entry . args)
|
||||
|
|
@ -319,18 +325,15 @@
|
|||
(apply values
|
||||
(ldap-first-attribute-internal session entry)))
|
||||
(lambda (attribute-name ber-element)
|
||||
(ddisplay "ldap-first-attribute " entry)
|
||||
(if attribute-name
|
||||
(cond
|
||||
((lookup-in-weak-table *object-table*
|
||||
(ber-element-c-pointer ber-element))
|
||||
=> (lambda (be)
|
||||
(ddisplay "ldap-first-attribute ber-element known "
|
||||
be)
|
||||
(ddisplay "RE ber-element (ldap-first-attribute) " be)
|
||||
(values attribute-name be)))
|
||||
(else
|
||||
(ddisplay "ldap-first-attribute ber-element unknown "
|
||||
ber-element)
|
||||
(ddisplay "NEW ber-element (ldap-first-attribute) " ber-element)
|
||||
(add-finalizer! ber-element ber-element-finalizer)
|
||||
(values attribute-name ber-element)))
|
||||
(raise-ldap-condition
|
||||
|
|
@ -462,21 +465,31 @@
|
|||
(cond
|
||||
((ldap-first-entry-internal session result)
|
||||
=> (lambda (new-message)
|
||||
(ddisplay "ldap-first-entry " result " " new-message)
|
||||
(let ((pointer (ldap-message-c-pointer new-message)))
|
||||
(or (lookup-in-weak-table *object-table* pointer)
|
||||
(begin
|
||||
(ddisplay "ldap-first-entry is new object")
|
||||
;; don't add a finalizer in this case, because
|
||||
;; libldap will free the memory itself.
|
||||
(add-to-weak-table! *object-table* pointer new-message)
|
||||
(set-ldap-message-session! new-message session)
|
||||
new-message)))))
|
||||
(else
|
||||
(let ((ret-obj (ldap-get-error-return-object session)))
|
||||
(if (ldap-success? ret-obj)
|
||||
#f
|
||||
(raise-ldap-condition ret-obj session)))))))
|
||||
(cond
|
||||
((lookup-in-weak-table *object-table* pointer)
|
||||
=> (lambda (old-object)
|
||||
(ddisplay "REUSE ldap-message as entry " old-object)
|
||||
;; nomitated in the category "hack of the year"
|
||||
(set-ldap-message-result! old-object old-object)
|
||||
old-object))
|
||||
(else
|
||||
;; it's not certain that this code will ever be reached.
|
||||
;;
|
||||
;; don't add a finalizer in this case, because
|
||||
;; libldap will free the memory itself.
|
||||
(ddisplay "NEW object (ldap-first-entry) result "
|
||||
result " new-message " new-message)
|
||||
(add-to-weak-table! *object-table* pointer new-message)
|
||||
(set-ldap-message-session! new-message session)
|
||||
(set-ldap-message-result! new-message result)
|
||||
(add-finalizer! new-message ldap-message-unregister-object)
|
||||
new-message))))
|
||||
(else
|
||||
(let ((ret-obj (ldap-get-error-return-object session)))
|
||||
(if (ldap-success? ret-obj)
|
||||
#f
|
||||
(raise-ldap-condition ret-obj session))))))))
|
||||
|
||||
(define (ldap-next-entry entry . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
|
|
@ -486,10 +499,13 @@
|
|||
(let ((pointer (ldap-message-c-pointer new-message)))
|
||||
(or (lookup-in-weak-table *object-table* pointer)
|
||||
(begin
|
||||
(ddisplay "NEW message (ldap-next-entry) " new-message
|
||||
" parent " (ldap-message-result entry))
|
||||
;; don't add a finalizer in this case, because
|
||||
;; libldap will free the memory itself.
|
||||
(add-to-weak-table! *object-table* pointer new-message)
|
||||
(set-ldap-message-session! new-message session)
|
||||
(set-ldap-message-result! new-message (ldap-message-result entry))
|
||||
(add-finalizer! new-message ldap-message-unregister-object)
|
||||
new-message)))))
|
||||
(else
|
||||
|
|
|
|||
|
|
@ -25,10 +25,13 @@
|
|||
|
||||
;;; This is the basic type
|
||||
(define-record-type ldap-message :ldap-message
|
||||
(make-ldap-message c-pointer session)
|
||||
(make-ldap-message c-pointer session result)
|
||||
ldap-message?
|
||||
(c-pointer ldap-message-c-pointer)
|
||||
(session ldap-message-session set-ldap-message-session!))
|
||||
;; the following fields are needed to implement automatic
|
||||
;; deallocation of ldap structures in C code
|
||||
(session ldap-message-session set-ldap-message-session!)
|
||||
(result ldap-message-result set-ldap-message-result!))
|
||||
|
||||
(define-exported-binding "ldap-message" :ldap-message)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue