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

@@ -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

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 "
+		  (ddisplay "RE ber-element (ldap-first-attribute) " be)
-			    be)
 		  (values attribute-name be)))
 	    (else
-	     (ddisplay "ldap-first-attribute ber-element unknown "
+	     (ddisplay "NEW ber-element (ldap-first-attribute) " ber-element)
-		       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)
+	     (cond
-		 (begin
+	      ((lookup-in-weak-table *object-table* pointer)
-		   (ddisplay "ldap-first-entry is new object")
+	       => (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)
-		   new-message)))))
+	       (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)))))))
+	     (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

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)