From e236fbaec4edfa663afd7330a8f0aaaf1ffc5177 Mon Sep 17 00:00:00 2001 From: eknauel Date: Sat, 14 Feb 2004 15:37:55 +0000 Subject: [PATCH] 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 --- scheme/interfaces.scm | 2 ++ scheme/ldap.scm | 72 ++++++++++++++++++++++++++----------------- scheme/types.scm | 7 +++-- 3 files changed, 51 insertions(+), 30 deletions(-) diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm index 2c0db5d..7286e60 100644 --- a/scheme/interfaces.scm +++ b/scheme/interfaces.scm @@ -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 diff --git a/scheme/ldap.scm b/scheme/ldap.scm index 3e09afc..d8239f1 100644 --- a/scheme/ldap.scm +++ b/scheme/ldap.scm @@ -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 diff --git a/scheme/types.scm b/scheme/types.scm index 79757cb..cb36431 100644 --- a/scheme/types.scm +++ b/scheme/types.scm @@ -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)