Lots of functions missing in various interfaces

scheme/interfaces.scm

@@ -1,14 +1,44 @@
 (define-interface ldap-low-interface
   (export
-   ldap-open
    ldap-init
-   ldap-bind-sync
+   ldap-simple-bind
-   ldap-unbind-sync
+   ldap-sasl-bind
-   ldap-error-string
+   ldap-unbind
-   ldap-result-error))
+   ldap-search
+
+   set-ldap-session-option!
+   ldap-session-option
+
+   ldap-first-message
+   ldap-next-message
+   ldap-count-messages
+   
+   ldap-get-message-type
+   ldap-get-message-id
+   
+   ldap-first-attribute
+   ldap-next-attribute
+   ldap-all-attributes
+
+   ldap-get-values
+   ldap-compare
+   ldap-message-dn
+   ldap-explode-dn
+   ldap-explode-rdn
+   ldap-make-dn-userfriendly
+   
+   ldap-count-entries
+   ldap-first-entry
+   ldap-next-entry
+
+   ldap-count-references
+   ldap-first-reference
+   ldap-next-reference))
    
 (define-interface ldap-conditions-interface
   (export
+   raise-ldap-condition
+
    &ldap-error ldap-error? ldap-error-code ldap-error-session
    &ldap-security-error ldap-security-error?
    &ldap-service-error ldap-service-error?
@@ -16,8 +46,8 @@
 
    &ldap-bindings-internal-error ldap-bindings-internal-error?
    &ldap-bindings-not-implemented ldap-bindings-not-implemented?
-   &ldap-session-option-error ldap-session-option-error?
    &ldap-implicit-unbind ldap-implicit-unbind?
+   &ldap-session-option-error ldap-session-option-error?
    &ldap-operations-error ldap-operations-error?
    &ldap-protocol-error ldap-protocol-error?
    &ldap-timelimit-exceeded ldap-timelimit-exceeded?
@@ -69,6 +99,11 @@
 (define-interface ldap-handle-types-interface
   (export
    ldap-session?
+   ldap-session-bound?
+   set-ldap-session-bound?!
+   ldap-session-options
+   ldap-session-messages
+
    ldap-message?
    ldap-modification?
 
@@ -77,14 +112,24 @@
    ldap-api-info-api-version
    ldap-api-info-protocol-version
    ldap-api-info-vendor-name
-   ldap-api-info-vendor-version))
+   ldap-api-info-vendor-version
+
+   make-session-options
+   set-ldap-session-options!
+   ldap-session-implicit-unbind-ok?
+   ldap-session-auto-unbind?
+
+   ldap-session-messages-adjoin!))
 
 (define-interface ldap-return-interface
   (export
    ldap-return-object?
    ldap-return-elements
    ldap-return-name
-   (ldap-return :syntax)))
+   (ldap-return :syntax)
+   convert-ldap-return-code
+   ldap-success?))
+  
 
 (define-interface ldap-option-version-interface
   (export
@@ -98,6 +143,7 @@
    ldap-scope-arguments-object?
    ldap-scope-arguments-elements
    ldap-scope-arguments-name
+   ldap-scope-arguments-id
    (ldap-scope-arguments :syntax)))
 
 (define-interface ldap-session-option-values-interface
@@ -105,6 +151,7 @@
    ldap-session-option-value-object?
    ldap-session-option-value-elements
    ldap-session-option-value-name
+   ldap-session-option-value-id
    (ldap-session-option-value :syntax)))
 
 (define-interface ldap-message-types-interface
@@ -112,7 +159,8 @@
    ldap-message-types-object?
    ldap-message-types-elements
    ldap-message-types-name
-   (ldap-message-types :syntax)))
+   (ldap-message-types :syntax)
+   convert-ldap-message-type))
 
 (define-interface ldap-attributes-special-values-interfaces
   (export 

scheme/ldap.scm

@@ -1,4 +1,3 @@
-; ,open define-record-types external-calls
 
 (import-lambda-definition ldap-session-free
   (session) 
@@ -7,7 +6,7 @@
 (define (ldap-session-finalizer 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 (session session))))
 	  (if (ldap-session-auto-unbind? session)
 	      (ldap-unbind session)))))
 
@@ -35,11 +34,11 @@
 
 (define (ldap-simple-bind session user password)
   (let ((ret-obj 
-	 (ldap-return
+	 (convert-ldap-return-code
 	  (ldap-simple-bind-internal session user password))))
     (if (ldap-success? ret-obj)
 	(set-ldap-session-bound?! session #t)
-	(raise-ldap-error ret-obj session))))
+	(raise-ldap-condition ret-obj session))))
 
 ;;; SASL_BIND_S
 
@@ -50,7 +49,7 @@
 (define (ldap-sasl-bind session dn mechanism cred 
 			server-controls client-controls
 			credentials)
-  (raise (condition (ldap-bindings-not-implemented 
+  (raise (condition (&ldap-bindings-not-implemented 
 		     (what '(ldap-sasl-bind ldap-controls))))))
 
 ;;; UNBIND_S
@@ -60,10 +59,11 @@
   "scsh_ldap_unbind_s")
 
 (define (ldap-unbind session)
-  (let ((ret-obj (ldap-return (ldap-unbind-internal session))))
+  (let ((ret-obj 
+	 (convert-ldap-return-code (ldap-unbind-internal session))))
     (if (ldap-success? ret-obj)
-	(set-ldap-session-bound?! ldap #f)
+	(set-ldap-session-bound?! session #f)
-	(raise-ldap-error ret-obj session))))
+	(raise-ldap-condition ret-obj session))))
 
 ;;; SEARCH_S and SEARCH_ST
 
@@ -91,7 +91,7 @@
 
 (define (ldap-search session base scope filter attribute-list attributes-only? . args)
   (let-optionals args ((timeout-seconds #f) (timeout-microseconds #f))
-    (let ((scope-id (ldap-scope-id scope))
+    (let ((scope-id (ldap-scope-arguments-id scope))
 	  (attr-list (ldap-attribute-list-kludge attribute-list)))
       (call-with-values
        (lambda ()
@@ -103,13 +103,14 @@
 		     session base scope filter attr-list attributes-only?
 		     timeout-seconds (or timeout-microseconds 0)))))
        (lambda (ret-code message)
-	 (let ((ret-obj (ldap-return ret-code)))
+	 (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)
 		 message)
-	       (raise-ldap-error ret-obj session))))))))
+	       (raise-ldap-condition ret-obj session))))))))
 
 ;;; GET/SET session options
 
@@ -122,7 +123,7 @@
    (lambda ()
      (apply values
 	    (ldap-get-set-option-internal 
-	     session (ldap-session-options-id session-option) #t value)))
+	     session (ldap-session-option-value-id session-option) #t value)))
    (lambda (call-successful? result)
      (if call-successful?
 	 result
@@ -134,7 +135,7 @@
    (lambda ()
      (apply values
 	    (ldap-get-set-option-internal
-	     session (ldap-session-options-id session-option) #f #f)))
+	     session (ldap-session-option-value-id session-option) #f #f)))
    (lambda (call-successful? result)
      (if call-successful?
 	 result
@@ -148,9 +149,8 @@
   "scsh_ldap_error_string")
 
 (define (ldap-get-error-return-object session)
-  (ldap-return
+  (ldap-session-option session 
-   (ldap-session-option 
+		       (ldap-session-option-value error-number)))
-    session (ldap-session-option error-number))))
 
 ;;; FIRST/NEXT_MESSAGE, COUNT_MESSAGES
 
@@ -160,7 +160,7 @@
 
 (define (ldap-first-message session message)
   (or (ldap-first-message-internal session message)
-      (raise-ldap-error 
+      (raise-ldap-condition 
        (ldap-get-error-return-object session) session)))
 
 (import-lambda-definition ldap-next-message-internal
@@ -169,7 +169,7 @@
 
 (define (ldap-next-message session message)
   (or (ldap-next-message-internal session message)
-      (raise-ldap-error
+      (raise-ldap-condition
        (ldap-get-error-return-object session) session)))
 
 (import-lambda-definition ldap-count-messages-internal
@@ -179,7 +179,7 @@
 (define (ldap-count-messages session message)
   (let ((ret (ldap-count-messages-internal session message)))
     (or ret
-	(raise-ldap-error (ldap-get-error-return-object session) session))))
+	(raise-ldap-condition (ldap-get-error-return-object session) session))))
 
 ;;;
 
@@ -190,9 +190,9 @@
 (define (ldap-get-message-type session message)
   (cond 
    ((ldap-get-message-type-internal message)
-    => (lambda (code) (ldap-message-type code)))
+    => (lambda (code) (convert-ldap-message-type code)))
    (else 
-    (raise-ldap-error (ldap-get-error-return-object session) session))))
+    (raise-ldap-condition (ldap-get-error-return-object session) session))))
 
 ;;;
 
@@ -201,8 +201,8 @@
   "scsh_ldap_msgid")
 
 (define (ldap-get-message-id session message)
-  (or (ldap-get-message-id-internal message)
+  (or (ldap-message-id-internal message)
-      (raise-ldap-error (ldap-get-error-return-object session) session)))
+      (raise-ldap-condition (ldap-get-error-return-object session) session)))
 			     
 ;;;
 
@@ -231,14 +231,14 @@
 	 (begin
 	   (add-finalizer! ber-element ber-element-finalizer)
 	   (values attribute-name ber-element))
-	 (raise-ldap-error (ldap-get-error-return-object session) session)))))
+	 (raise-ldap-condition (ldap-get-error-return-object session) session)))))
 
 (define (ldap-next-attribute session 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
-	    (raise-ldap-error ret-obj session)))))
+	    (raise-ldap-condition ret-obj session)))))
 
 (define (ldap-all-attributes session entry)
   (call-with-values
@@ -260,7 +260,7 @@
 
 (define (ldap-get-values session entry attribute-name)
   (or (ldap-get-values-internal session entry attribute-name)
-      (raise-ldap-error (ldap-get-error-return-object session) session)))
+      (raise-ldap-condition (ldap-get-error-return-object session) session)))
 
 ;;;
 
@@ -270,12 +270,12 @@
 
 (define (ldap-compare session dn attribute value)
   (let ((ret-obj 
-	 (ldap-return 
+	 (convert-ldap-return-code
 	  (ldap-compare-internal session dn attribute value))))
     (if (or (equal? (ldap-return compare-true) ret-obj)
 	    (equal? (ldap-return compare-false) ret-obj))
 	(equal? (ldap-return compare-true) ret-obj)
-	(raise-ldap-error ret-obj session))))
+	(raise-ldap-condition ret-obj session))))
 
 ;;;
 
@@ -285,7 +285,7 @@
 
 (define (ldap-message-dn session entry)
   (or (ldap-get-dn-internal session entry)
-      (raise-ldap-error (ldap-get-error-return-object session) session)))
+      (raise-ldap-condition (ldap-get-error-return-object session) session)))
 
 ;;;
 
@@ -295,7 +295,7 @@
 
 (define (ldap-explode-dn session dn no-types?)
   (or (ldap-explode-dn-internal dn no-types?)
-      (raise-ldap-error (ldap-get-error-return-object session) session)))
+      (raise-ldap-condition (ldap-get-error-return-object session) session)))
 
 ;;;
 
@@ -305,7 +305,7 @@
 
 (define (ldap-explode-rdn session dn no-types?)
   (or (ldap-explode-rdn-internal dn no-types?)
-      (raise-ldap-error (ldap-get-error-return-object session dn no-types?))))
+      (raise-ldap-condition (ldap-get-error-return-object session dn no-types?))))
 
 ;;;
 
@@ -315,7 +315,7 @@
 
 (define (ldap-make-dn-userfriendly session dn)
   (or (ldap-dn2ufn-internal dn)
-      (raise-ldap-error (ldap-get-error-return-object session) session)))
+      (raise-ldap-condition (ldap-get-error-return-object session) session)))
 
 ;;;
 
@@ -333,7 +333,7 @@
 
 (define (ldap-count-entries session message)
   (or (ldap-count-entries-internal session message)
-      (raise-ldap-error (ldap-get-error-return-object session) session)))
+      (raise-ldap-condition (ldap-get-error-return-object session) session)))
 
 (define (ldap-first-entry session message)
   (cond 
@@ -345,7 +345,7 @@
     (let ((ret-obj (ldap-get-error-return-object session)))
       (if (ldap-success? ret-obj)
 	  #f
-	  (raise-ldap-error ret-obj session))))))
+	  (raise-ldap-condition ret-obj session))))))
 
 (define (ldap-next-entry session message)
   (cond 
@@ -357,7 +357,7 @@
     (let ((ret-obj (ldap-get-error-return-object session)))
       (if (ldap-success? ret-obj)
 	  #f
-	  (raise-ldap-error ret-obj session))))))
+	  (raise-ldap-condition ret-obj session))))))
 
 ;;;
 
@@ -375,7 +375,7 @@
 
 (define (ldap-count-references session message)
   (or (ldap-count-references-internal session message)
-      (raise-ldap-error (ldap-get-error-return-object session) session)))
+      (raise-ldap-condition (ldap-get-error-return-object session) session)))
 
 (define (ldap-first-reference session message)
   (cond
@@ -387,7 +387,7 @@
     (let ((ret-obj (ldap-get-error-return-object session)))
       (if (ldap-success? ret-obj)
 	  #f
-	  (raise-ldap-error ret-obj session))))))
+	  (raise-ldap-condition ret-obj session))))))
 
 (define (ldap-next-reference session message)
   (cond 
@@ -399,7 +399,7 @@
     (let ((ret-obj (ldap-get-error-return-object session)))
       (if (ldap-success? ret-obj)
 	  #f
-	  (raise-ldap-error ret-obj session))))))
+	  (raise-ldap-condition ret-obj session))))))
 
 ;;;
 
@@ -407,6 +407,17 @@
   (session dn ldap-modification-vector)
   "scsh_ldap_modify")
 
+(define (ldap-modify session dn ldap-modifications)
+  (let ((vec (if (list? ldap-modifications)
+		 (list->vector ldap-modifications)
+		 (vector ldap-modifications))))
+    (let ((ret-obj 
+	   (convert-ldap-return-code (ldap-modify-internal session dn vec))))
+      (or (ldap-success? ret-obj)
+	  (raise-ldap-condition ret-obj session)))))
+
+;;;
+
 (import-lambda-definition ldap-add-internal
   (session dn ldap-modification-vector) 
   "scsh_ldap_add")
@@ -419,9 +430,3 @@
   (session message-id)
   "scsh_ldap_abandon")
 				    
-;;; import functions from C
-(define c-value->ldap-success
-  (make-finite-type-import-function 
-   'ldap-success ldap-success-elements ldap-success-id))
-
-				    

scheme/packages.scm

@@ -3,8 +3,12 @@
 	define-record-types
 	primitives	
 	external-calls
+	let-opt
 	srfi-34 srfi-35
-	ffi-tools-rts)
+	ffi-tools-rts
+
+	ldap-conditions
+	ldap-types)
   (files ldap))
 
 (define-structure ldap-types ldap-types-interface