scsh-ldap/scheme/ldap-constants.scm

(define-interface ldap-constants-interface
  (export 
   make-c-files
   make-scm-files))

(define-structure ldap-constants ldap-constants-interface
  (open
   scheme signals srfi-13
   ffi-import-constants)
  (begin

    (define ldap-return-codes
      (map make-constant-from-c-name-integer
	   '("LDAP_SUCCESS"
	     "LDAP_OPERATIONS_ERROR"
	     "LDAP_PROTOCOL_ERROR"
	     "LDAP_TIMELIMIT_EXCEEDED"
	     "LDAP_SIZELIMIT_EXCEEDED"
	     "LDAP_COMPARE_FALSE"
	     "LDAP_COMPARE_TRUE"
	     "LDAP_STRONG_AUTH_NOT_SUPPORTED"
	     "LDAP_STRONG_AUTH_REQUIRED"
	     "LDAP_REFERRAL"
	     "LDAP_ADMINLIMIT_EXCEEDED"
	     "LDAP_UNAVAILABLE_CRITICAL_EXTENSION"
	     "LDAP_CONFIDENTIALITY_REQUIRED"
	     "LDAP_SASL_BIND_IN_PROGRESS"
	     "LDAP_NO_SUCH_ATTRIBUTE"
	     "LDAP_UNDEFINED_TYPE"
	     "LDAP_INAPPROPRIATE_MATCHING"
	     "LDAP_CONSTRAINT_VIOLATION"
	     "LDAP_TYPE_OR_VALUE_EXISTS"
	     "LDAP_INVALID_SYNTAX"
	     "LDAP_NO_SUCH_OBJECT"
	     "LDAP_ALIAS_PROBLEM"
	     "LDAP_INVALID_DN_SYNTAX"
	     "LDAP_IS_LEAF"
	     "LDAP_ALIAS_DEREF_PROBLEM"
	     "LDAP_INAPPROPRIATE_AUTH"
	     "LDAP_INVALID_CREDENTIALS"
	     "LDAP_INSUFFICIENT_ACCESS"
	     "LDAP_BUSY"
	     "LDAP_UNAVAILABLE"
	     "LDAP_UNWILLING_TO_PERFORM"
	     "LDAP_LOOP_DETECT"
	     "LDAP_NAMING_VIOLATION"
	     "LDAP_OBJECT_CLASS_VIOLATION"
	     "LDAP_NOT_ALLOWED_ON_NONLEAF"
	     "LDAP_NOT_ALLOWED_ON_RDN"
	     "LDAP_ALREADY_EXISTS"
	     "LDAP_NO_OBJECT_CLASS_MODS"
	     "LDAP_RESULTS_TOO_LARGE"
	     "LDAP_AFFECTS_MULTIPLE_DSAS"
	     "LDAP_OTHER"
	     "LDAP_SERVER_DOWN"
	     "LDAP_LOCAL_ERROR"
	     "LDAP_ENCODING_ERROR"
	     "LDAP_DECODING_ERROR"
	     "LDAP_TIMEOUT"
	     "LDAP_AUTH_UNKNOWN"
	     "LDAP_FILTER_ERROR"
	     "LDAP_USER_CANCELLED"
	     "LDAP_PARAM_ERROR"
	     "LDAP_NO_MEMORY"
	     "LDAP_CONNECT_ERROR"
	     "LDAP_NOT_SUPPORTED"
	     "LDAP_CONTROL_NOT_FOUND"
	     "LDAP_NO_RESULTS_RETURNED"
	     "LDAP_MORE_RESULTS_TO_RETURN"
	     "LDAP_CLIENT_LOOP"
	     "LDAP_REFERRAL_LIMIT_EXCEEDED")))

    (define ldap-opt-protocol-version
      (map make-constant-from-c-name-integer
	   '("LDAP_VERSION" "LDAP_VERSION3")))

    (define ldap-scope-arguments
      (map make-constant-from-c-name-integer
	   '("LDAP_SCOPE_BASE" "LDAP_SCOPE_ONELEVEL" "LDAP_SCOPE_SUBTREE")))

    (define ldap-session-option-values
      (map make-constant-from-c-name-integer
	   '("LDAP_OPT_API_INFO" 
	     "LDAP_OPT_DEREF" 
	     "LDAP_OPT_SIZELIMIT"
	     "LDAP_OPT_TIMELIMIT"
	     "LDAP_OPT_REFERRALS"
	     "LDAP_OPT_RESTART"
	     "LDAP_OPT_PROTOCOL_VERSION"
	     "LDAP_OPT_SERVER_CONTROLS"
	     "LDAP_OPT_CLIENT_CONTROLS"
	     "LDAP_OPT_API_FEATURE_INFO"
	     "LDAP_OPT_HOST_NAME"
	     "LDAP_OPT_ERROR_NUMBER"
	     "LDAP_OPT_ERROR_STRING"
	     "LDAP_OPT_MATCHED_DN")))

    (define ldap-attribute-selectors
      (list
       (make-string-constant 
	"LDAP_NO_ATTRS" "ldap-attributes-no-attribute")
       (make-string-constant 
	"LDAP_ALL_USER_ATTRIBUTES" "ldap-attributes-all-user-attributes")))

    (define ldap-message-types
      (map make-constant-from-c-name-integer
	   '("LDAP_RES_BIND"
	     "LDAP_RES_SEARCH_ENTRY"
	     "LDAP_RES_SEARCH_REFERENCE"
	     "LDAP_RES_SEARCH_RESULT"
	     "LDAP_RES_MODIFY"
	     "LDAP_RES_ADD"
	     "LDAP_RES_DELETE"
	     "LDAP_RES_MODDN"
	     "LDAP_RES_COMPARE"
	     "LDAP_RES_EXTENDED")))

    (define ldap-operation
      (map make-constant-from-c-name-integer
	   '("LDAP_MOD_ADD"
	     "LDAP_MOD_DELETE"
	     "LDAP_MOD_REPLACE")))

    (define ldap-all-constants
      (append ldap-return-codes
	      ldap-opt-protocol-version
	      ldap-scope-arguments
	      ldap-attribute-selectors
	      ldap-session-option-values
	      ldap-message-types
	      ldap-operation))
	   
    (define (write-source-file name string)
      (call-with-output-file name
	(lambda (port)
	  (display string port))))

    (define (generate-ldap-consts-c path)
      (write-source-file
       (string-append path "/ldap-consts.c")
       (string-append

	"#include \"scheme48.h\"\n"
	"#include <ldap.h>\n"

	(generate-c-declarations ldap-all-constants)

	(generate-c-define-exported-bindings-function
	 "scsh_ldap_constants_export_bindings"
	 ldap-all-constants)

	(generate-c-enter-values-function 
	 "scsh_ldap_enter_ldap_constants"
	 ldap-all-constants)

	(generate-c-gc-protect-globals-function
	 "scsh_ldap_gc_protect_globals"
	 ldap-all-constants))))

    (define (generate-const-gen-scm path)
      (write-source-file 
       (string-append path "/const-gen.scm")
       (string-append

	(generate-finite-type-definition 
	 "ldap-return" (make-drop-common-prefix-name-converter "LDAP_")
	 ldap-return-codes)

	(generate-finite-type-definition
	 "ldap-option-version" (make-drop-common-prefix-name-converter "LDAP_")
	 ldap-opt-protocol-version)

	(generate-finite-type-definition
	 "ldap-scope-arguments" (make-drop-common-prefix-name-converter "LDAP_SCOPE_")
	 ldap-scope-arguments)

	(generate-finite-type-definition
	 "ldap-session-option-value" (make-drop-common-prefix-name-converter "LDAP_OPT_")
	 ldap-session-option-values)

	(generate-finite-type-definition
	 "ldap-message-types" (make-drop-common-prefix-name-converter "LDAP_RES_")
	 ldap-message-types)

	(generate-finite-type-definition
	 "ldap-operation" (make-drop-common-prefix-name-converter "LDAP_MOD_")
	 ldap-operation)

	(string-join
	 (map generate-binding ldap-attribute-selectors)))))

    (define (make-c-files args)
      (if (null? args)
	  (error "missing parameter")
	  (let ((path (car args)))
	    (generate-ldap-consts-c path))))

    (define (make-scm-files args)
      (if (null? args)
	  (error "missing parameter")
	  (let ((path (car args)))
	    (generate-const-gen-scm path))))

))