many GC-related changes. Use weak table to avoid creating a second
scheme object for the same ldap object. Works partially.
This commit is contained in:
eknauel
parent
cd2e6cff48
commit
55f238280a
166
scheme/ldap.scm
166
scheme/ldap.scm
|
|
@ -1,3 +1,20 @@
|
|||
(define ddisplay
|
||||
(lambda lst
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(cond
|
||||
((ldap-message? x)
|
||||
(display (number->string (ldap-message-c-pointer x) 16)))
|
||||
((ber-element? x)
|
||||
(display (number->string (ber-element-c-pointer x) 16)))
|
||||
(else
|
||||
(display x))))
|
||||
lst)
|
||||
(newline)
|
||||
(force-output (current-output-port))))
|
||||
|
||||
(define *object-table*
|
||||
(make-value-weak-table))
|
||||
|
||||
(define $current-ldap-session (make-fluid #f))
|
||||
|
||||
|
|
@ -12,11 +29,14 @@
|
|||
"scsh_ldap_memfree")
|
||||
|
||||
(define (ldap-session-finalizer session)
|
||||
(ddisplay "Finalizing session" (ldap-session-c-pointer session))
|
||||
(if (ldap-session-bound? session)
|
||||
(if (not (ldap-session-implicit-unbind-ok? session))
|
||||
(raise (condition (&ldap-implicit-unbind (session session))))
|
||||
(if (ldap-session-auto-unbind? session)
|
||||
(ldap-unbind session)))))
|
||||
(ldap-unbind session))))
|
||||
(remove-from-weak-table! *object-table* (ldap-session-c-pointer session))
|
||||
(ldap-session-free session))
|
||||
|
||||
(import-lambda-definition ldap-init-internal
|
||||
(host port)
|
||||
|
|
@ -33,10 +53,12 @@
|
|||
(let ((session (ldap-init-internal hosts port))
|
||||
(options (make-session-options implicit-unbind-ok?
|
||||
unbind-automatically?)))
|
||||
(add-to-weak-table! *object-table*
|
||||
(ldap-session-c-pointer session)
|
||||
session)
|
||||
(add-finalizer! session ldap-session-finalizer)
|
||||
(set-ldap-session-bound?! session #f)
|
||||
(set-ldap-session-options! session options)
|
||||
(set-ldap-session-messages! session '())
|
||||
session))))
|
||||
|
||||
;;; SIMPLE_BIND_S
|
||||
|
|
@ -54,7 +76,7 @@
|
|||
(set-ldap-session-bound?! session #t)
|
||||
(raise-ldap-condition ret-obj session)))))
|
||||
|
||||
(define (ldap-simple-bind-as-nobody . args)
|
||||
(define (ldap-simple-bind-anonymous . args)
|
||||
(let-optionals args ((session . (current-ldap-session)))
|
||||
(ldap-simple-bind #f #f session)))
|
||||
|
||||
|
|
@ -97,12 +119,19 @@
|
|||
(session base scope filter attribute-list attributes-only? timeout-sec timeout-usec)
|
||||
"scsh_ldap_search_st")
|
||||
|
||||
(import-lambda-definition ldap-msgfree-internal
|
||||
(import-lambda-definition ldap-msgfree
|
||||
(message)
|
||||
"scsh_ldap_msgfree")
|
||||
|
||||
(define (ldap-message-finalizer message)
|
||||
(ldap-msgfree-internal message))
|
||||
(define (ldap-message-unregister-object message)
|
||||
(ddisplay "Message unregistering finalizer " (ldap-message-c-pointer 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))
|
||||
(ldap-message-unregister-object message)
|
||||
(ldap-msgfree message))
|
||||
|
||||
(define (ldap-attribute-list-kludge attribute-list)
|
||||
(cond ((eq? attribute-list ldap-attributes-no-attribute)
|
||||
|
|
@ -130,10 +159,15 @@
|
|||
(let ((ret-obj
|
||||
(convert-ldap-return-code ret-code)))
|
||||
(if (ldap-success? ret-obj)
|
||||
(begin
|
||||
(ldap-session-messages-adjoin! session message)
|
||||
(add-finalizer! message ldap-message-finalizer)
|
||||
(make-ldap-entry message))
|
||||
(let ((pointer (ldap-message-c-pointer message)))
|
||||
(ddisplay "ldap-search")
|
||||
(or (lookup-in-weak-table *object-table* pointer)
|
||||
(begin
|
||||
(ddisplay "ldap-search new object " message)
|
||||
(add-to-weak-table! *object-table* pointer message)
|
||||
(set-ldap-message-session! message session)
|
||||
(add-finalizer! message ldap-message-freeing-finalizer)
|
||||
message)))
|
||||
(raise-ldap-condition ret-obj session))))))))
|
||||
|
||||
;;; GET/SET session options
|
||||
|
|
@ -186,19 +220,39 @@
|
|||
|
||||
(define (ldap-first-message message . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(or (ldap-first-message-internal session message)
|
||||
(raise-ldap-condition
|
||||
(ldap-get-error-return-object session) session))))
|
||||
(cond
|
||||
((ldap-first-message-internal session message)
|
||||
=> (lambda (new-message)
|
||||
(let ((pointer (ldap-message-c-pointer new-message)))
|
||||
(or (lookup-in-weak-table *object-table* pointer)
|
||||
(begin
|
||||
(add-to-weak-table! *object-table* pointer new-message)
|
||||
(set-ldap-message-session! new-message session)
|
||||
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
||||
new-message)))))
|
||||
(else
|
||||
(raise-ldap-condition
|
||||
(ldap-get-error-return-object session) session)))))
|
||||
|
||||
(import-lambda-definition ldap-next-message-internal
|
||||
(session message)
|
||||
"scsh_ldap_next_message")
|
||||
|
||||
(define (ldap-next-message message . args)
|
||||
(define (ldap-next-message message . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(or (ldap-next-message-internal session message)
|
||||
(raise-ldap-condition
|
||||
(ldap-get-error-return-object session) session))))
|
||||
(cond
|
||||
((ldap-next-message-internal session message)
|
||||
=> (lambda (new-message)
|
||||
(let ((pointer (ldap-message-c-pointer new-message)))
|
||||
(or (lookup-in-weak-table *object-table* pointer)
|
||||
(begin
|
||||
(add-to-weak-table! *object-table* pointer new-message)
|
||||
(set-ldap-message-session! new-message session)
|
||||
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
||||
new-message)))))
|
||||
(else
|
||||
(raise-ldap-condition
|
||||
(ldap-get-error-return-object session) session)))))
|
||||
|
||||
(import-lambda-definition ldap-count-messages-internal
|
||||
(session message)
|
||||
|
|
@ -219,7 +273,7 @@
|
|||
(message)
|
||||
"scsh_ldap_msgtype")
|
||||
|
||||
(define (ldap-get-message-type session message)
|
||||
(define (ldap-message-type session message)
|
||||
(cond
|
||||
((ldap-get-message-type-internal message)
|
||||
=> (lambda (code) (convert-ldap-message-type code)))
|
||||
|
|
@ -252,6 +306,10 @@
|
|||
"scsh_ldap_ber_free")
|
||||
|
||||
(define (ber-element-finalizer 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)
|
||||
|
|
@ -259,17 +317,28 @@
|
|||
(call-with-values
|
||||
(lambda ()
|
||||
(apply values
|
||||
(ldap-first-attribute-internal session (ldap-entry-message entry))))
|
||||
(ldap-first-attribute-internal session entry)))
|
||||
(lambda (attribute-name ber-element)
|
||||
(ddisplay "ldap-first-attribute " entry)
|
||||
(if attribute-name
|
||||
(begin
|
||||
(cond
|
||||
((lookup-in-weak-table *object-table*
|
||||
(ber-element-c-pointer ber-element))
|
||||
=> (lambda (be)
|
||||
(ddisplay "ldap-first-attribute ber-element known "
|
||||
be)
|
||||
(values attribute-name be)))
|
||||
(else
|
||||
(ddisplay "ldap-first-attribute ber-element unknown "
|
||||
ber-element)
|
||||
(add-finalizer! ber-element ber-element-finalizer)
|
||||
(values attribute-name ber-element))
|
||||
(raise-ldap-condition (ldap-get-error-return-object session) session))))))
|
||||
(values attribute-name ber-element)))
|
||||
(raise-ldap-condition
|
||||
(ldap-get-error-return-object session) session))))))
|
||||
|
||||
(define (ldap-next-attribute entry ber-element . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(or (ldap-next-attribute-internal session (ldap-entry-message entry) ber-element)
|
||||
(or (ldap-next-attribute-internal session entry ber-element)
|
||||
(let ((ret-obj (ldap-get-error-return-object session)))
|
||||
(if (ldap-success? ret-obj)
|
||||
#f
|
||||
|
|
@ -297,7 +366,7 @@
|
|||
(define (ldap-get-values entry attribute-name . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(let ((val (ldap-get-values-internal
|
||||
session (ldap-entry-message entry) attribute-name)))
|
||||
session entry attribute-name)))
|
||||
(or val
|
||||
(let ((ret-obj (ldap-get-error-return-object session)))
|
||||
(if (ldap-success? ret-obj)
|
||||
|
|
@ -306,7 +375,7 @@
|
|||
|
||||
;;;
|
||||
|
||||
(import-lambda-definition ldap-compare-internal
|
||||
(import-lambda-definition ldap-compare-internal
|
||||
(session dn attribute value)
|
||||
"scsh_ldap_compare_s")
|
||||
|
||||
|
|
@ -328,7 +397,7 @@
|
|||
|
||||
(define (ldap-entry-dn entry . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(or (ldap-get-dn-internal session (ldap-entry-message entry))
|
||||
(or (ldap-get-dn-internal session entry)
|
||||
(raise-ldap-condition
|
||||
(ldap-get-error-return-object session) session))))
|
||||
|
||||
|
|
@ -384,17 +453,25 @@
|
|||
|
||||
(define (ldap-count-entries entry . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(or (ldap-count-entries-internal session (ldap-entry-message entry))
|
||||
(or (ldap-count-entries-internal session entry)
|
||||
(raise-ldap-condition
|
||||
(ldap-get-error-return-object session) session))))
|
||||
|
||||
(define (ldap-first-entry entry . args)
|
||||
(define (ldap-first-entry result . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(cond
|
||||
((ldap-first-entry-internal session (ldap-entry-message entry))
|
||||
((ldap-first-entry-internal session result)
|
||||
=> (lambda (new-message)
|
||||
(add-finalizer! new-message ldap-message-finalizer)
|
||||
(make-ldap-entry 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)
|
||||
|
|
@ -404,15 +481,22 @@
|
|||
(define (ldap-next-entry entry . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(cond
|
||||
((ldap-next-entry-internal session (ldap-entry-message entry))
|
||||
((ldap-next-entry-internal session entry)
|
||||
=> (lambda (new-message)
|
||||
(add-finalizer! new-message ldap-message-finalizer)
|
||||
(make-ldap-entry new-message)))
|
||||
(let ((pointer (ldap-message-c-pointer new-message)))
|
||||
(or (lookup-in-weak-table *object-table* pointer)
|
||||
(begin
|
||||
;; 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)
|
||||
(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)))))))
|
||||
(let ((ret-obj (ldap-get-error-return-object session)))
|
||||
(if (ldap-success? ret-obj)
|
||||
#f
|
||||
(raise-ldap-condition ret-obj session)))))))
|
||||
|
||||
;;;
|
||||
|
||||
|
|
@ -428,6 +512,7 @@
|
|||
(session message)
|
||||
"scsh_ldap_next_reference")
|
||||
|
||||
;;; FIXME: maybe add type, memory handling
|
||||
(define (ldap-count-references message . args)
|
||||
(let-optionals args ((session (current-ldap-session)))
|
||||
(or (ldap-count-references-internal session message)
|
||||
|
|
@ -438,7 +523,7 @@
|
|||
(cond
|
||||
((ldap-first-reference-internal session message)
|
||||
=> (lambda (new-message)
|
||||
(add-finalizer! new-message ldap-message-finalizer)
|
||||
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
||||
new-message))
|
||||
(else
|
||||
(let ((ret-obj (ldap-get-error-return-object session)))
|
||||
|
|
@ -451,7 +536,7 @@
|
|||
(cond
|
||||
((ldap-next-reference-internal session message)
|
||||
=> (lambda (new-message)
|
||||
(add-finalizer! new-message ldap-message-finalizer)
|
||||
(add-finalizer! new-message ldap-message-freeing-finalizer)
|
||||
new-message))
|
||||
(else
|
||||
(let ((ret-obj (ldap-get-error-return-object session)))
|
||||
|
|
@ -488,4 +573,3 @@
|
|||
(import-lambda-definition ldap-abandon-internal
|
||||
(session message-id)
|
||||
"scsh_ldap_abandon")
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue