scsh-conservatory
/
scsh-ldap
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

get rid of some superfluous CALL-WITH-VALUES

This commit is contained in:
eknauel 2004-05-21 08:33:14 +00:00
parent 5ceffe5e91
commit 379e176e6a
1 changed files with 29 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
scheme/ldap.scm
View File

@ -165,15 +165,7 @@
(timeout-microseconds #f))
(let ((scope-id (ldap-scope-arguments-id scope))
(attr-list (ldap-attribute-list-kludge attribute-list)))
(call-with-values
(lambda ()
(apply values
(if (not timeout-seconds)
(ldap-search-internal
session base scope-id filter attr-list attributes-only?)
(ldap-search-with-timeout-internal
session base scope-id filter attr-list attributes-only?
timeout-seconds (or timeout-microseconds 0)))))
(apply
(lambda (ret-code message)
(let ((ret-obj
(convert-ldap-return-code ret-code)))
@ -184,13 +176,19 @@
(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)
message)))
(raise-ldap-condition ret-obj session))))))))
(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)
message)))
(raise-ldap-condition ret-obj session))))
(if (not timeout-seconds)
(ldap-search-internal
session base scope-id filter attr-list attributes-only?)
(ldap-search-with-timeout-internal
session base scope-id filter attr-list attributes-only?
timeout-seconds (or timeout-microseconds 0)))))))
;;; GET/SET session options
(import-lambda-definition ldap-get-set-option-internal
@ -199,31 +197,26 @@
(define (set-ldap-session-option! session-option value . args)
(let-optionals args ((session (current-ldap-session)))
(call-with-values
(lambda ()
(apply values
(ldap-get-set-option-internal
session (ldap-session-option-value-id session-option) #t value)))
(apply
(lambda (call-successful? result)
(if call-successful?
result
(raise
(condition (&ldap-session-option-error
(code #f) (session session)))))))))
(code #f) (session session))))))
(ldap-get-set-option-internal
session (ldap-session-option-value-id session-option) #t value))))
(define (ldap-session-option session-option . args)
(let-optionals args ((session (current-ldap-session)))
(call-with-values
(lambda ()
(apply values
(ldap-get-set-option-internal
session (ldap-session-option-value-id session-option) #f #f)))
(apply
(lambda (call-successful? result)
(if call-successful?
result
(raise
(condition (&ldap-session-option-error
(code #f) (session session)))))))))
(raise (condition (&ldap-session-option-error
(code #f) (session session))))))
(ldap-get-set-option-internal
session (ldap-session-option-value-id session-option) #f #f))))
;;;
@ -338,10 +331,7 @@
(define (ldap-first-attribute entry . args)
(let-optionals args ((session (current-ldap-session)))
(call-with-values
(lambda ()
(apply values
(ldap-first-attribute-internal session entry)))
(apply
(lambda (attribute-name ber-element)
(if attribute-name
(cond
@ -356,7 +346,8 @@
(add-finalizer! ber-element ber-element-finalizer)
(values attribute-name ber-element)))
(raise-ldap-condition
(ldap-get-error-return-object session) session))))))
(ldap-get-error-return-object session) session)))
(ldap-first-attribute-internal session entry))))
(define (ldap-next-attribute entry ber-element . args)
(let-optionals args ((session (current-ldap-session)))
@ -368,16 +359,15 @@
(define (ldap-all-attributes entry . args)
(let-optionals args ((session (current-ldap-session)))
(call-with-values
(lambda ()
(ldap-first-attribute entry session))
(apply
(lambda (first-attribute ber-element)
(let loop ((next (ldap-next-attribute entry ber-element session))
(attributes (list first-attribute)))
(if next
(loop (ldap-next-attribute entry ber-element session)
(cons next attributes))
attributes))))))
attributes)))
(ldap-first-attribute entry session))))
;;;