diff --git a/scheme/ldap.scm b/scheme/ldap.scm index 8fe2b79..e3bc989 100644 --- a/scheme/ldap.scm +++ b/scheme/ldap.scm @@ -18,6 +18,8 @@ (define *object-table* (make-value-weak-table)) +;;; ldap session as a fluid + (define $current-ldap-session (make-fluid #f)) (define (current-ldap-session) @@ -26,20 +28,32 @@ (define (with-ldap-session session thunk) (let-fluid $current-ldap-session session thunk)) +;;; free ldap session handles + (import-lambda-definition ldap-session-free (session) "scsh_ldap_memfree") +(define (ldap-session-finalizer-free session) + (ddisplay 'ldap-session-finalizer-free session) + (remove-from-weak-table! *object-table* + (ldap-session-c-pointer session)) + (ldap-session-free session)) + (define (ldap-session-finalizer session) - (ddisplay "FREE ldap-session " session) + (ddisplay 'ldap-session-finalizer session) (if (ldap-session-bound? session) (if (not (ldap-session-implicit-unbind-ok? 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)) - (ldap-session-free session)) + (ldap-session-weak-list-filter! session) + (if (null? (ldap-session-weak-list session)) + (add-finalizer! session ldap-session-finalizer-free) + (add-finalizer! session ldap-session-finalizer))) + +;;; ldap init (import-lambda-definition ldap-init-internal (host port) @@ -62,6 +76,7 @@ (add-finalizer! session ldap-session-finalizer) (set-ldap-session-bound?! session #f) (set-ldap-session-options! session options) + (set-ldap-session-weak-list! session '()) session)))) ;;; SIMPLE_BIND_S @@ -169,6 +184,7 @@ (begin (ddisplay "ldap-search new object " message) (add-to-weak-table! *object-table* pointer message) + (ldap-session-weak-list-add! session message) (set-ldap-message-session! message session) (set-ldap-message-result! message #f) (add-finalizer! message ldap-message-freeing-finalizer) @@ -234,6 +250,7 @@ (or (lookup-in-weak-table *object-table* pointer) (begin (add-to-weak-table! *object-table* pointer new-message) + (ldap-session-weak-list-add! session new-message) (set-ldap-message-session! new-message session) (add-finalizer! new-message ldap-message-freeing-finalizer) new-message))))) @@ -254,6 +271,7 @@ (or (lookup-in-weak-table *object-table* pointer) (begin (add-to-weak-table! *object-table* pointer new-message) + (ldap-session-weak-list-add! session new-message) (set-ldap-message-session! new-message session) (add-finalizer! new-message ldap-message-freeing-finalizer) new-message))))) @@ -334,6 +352,7 @@ (values attribute-name be))) (else (ddisplay "NEW ber-element (ldap-first-attribute) " ber-element) + (ldap-session-weak-list-add! session ber-element) (add-finalizer! ber-element ber-element-finalizer) (values attribute-name ber-element))) (raise-ldap-condition @@ -481,6 +500,7 @@ (ddisplay "NEW object (ldap-first-entry) result " result " new-message " new-message) (add-to-weak-table! *object-table* pointer new-message) + (ldap-session-weak-list-add! session new-message) (set-ldap-message-session! new-message session) (set-ldap-message-result! new-message result) (add-finalizer! new-message ldap-message-unregister-object) @@ -504,6 +524,7 @@ ;; don't add a finalizer in this case, because ;; libldap will free the memory itself. (add-to-weak-table! *object-table* pointer new-message) + (ldap-session-weak-list-add! session 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) @@ -540,6 +561,7 @@ ((ldap-first-reference-internal session message) => (lambda (new-message) (add-finalizer! new-message ldap-message-freeing-finalizer) + (ldap-session-weak-list-add! session new-message) new-message)) (else (let ((ret-obj (ldap-get-error-return-object session))) @@ -553,6 +575,7 @@ ((ldap-next-reference-internal session message) => (lambda (new-message) (add-finalizer! new-message ldap-message-freeing-finalizer) + (ldap-session-weak-list-add! session new-message) new-message)) (else (let ((ret-obj (ldap-get-error-return-object session)))