231 lines
6.7 KiB
Scheme
231 lines
6.7 KiB
Scheme
|
|
(define-syntax lookup-shared-value
|
|
(syntax-rules ()
|
|
((lookup-shared-valued str)
|
|
(shared-binding-ref (lookup-imported-binding str)))))
|
|
|
|
(define yp-error-code-alist
|
|
`((,(lookup-shared-value "yp-error-badargs") . yp-bad-arguments)
|
|
(,(lookup-shared-value "yp-error-baddb") . yp-bad-database)
|
|
(,(lookup-shared-value "yp-error-domain") . yp-bad-domain)
|
|
(,(lookup-shared-value "yp-error-key") . yp-unknown-key)
|
|
(,(lookup-shared-value "yp-error-map") . yp-unknown-map)
|
|
(,(lookup-shared-value "yp-error-nodom") . yp-no-domain)
|
|
(,(lookup-shared-value "yp-error-pmap") . yp-portmap-failure)
|
|
(,(lookup-shared-value "yp-error-resrc") . yp-allocation-failure)
|
|
(,(lookup-shared-value "yp-error-rpc") . yp-rpc-failure)
|
|
(,(lookup-shared-value "yp-error-bind") . yp-bind-failure)
|
|
(,(lookup-shared-value "yp-error-yperr") . yp-internal-error)
|
|
(,(lookup-shared-value "yp-error-ypserv") . yp-server-error)))
|
|
|
|
(define (raise-yp-error code . args)
|
|
(cond
|
|
((assoc code yp-error-code-alist)
|
|
=> (lambda (code.ctype)
|
|
(let ((ctype (cdr code.ctype)))
|
|
(apply signal ctype
|
|
(append (list ctype (car code.ctype)) args)))))
|
|
(else
|
|
(error "scsh-yp internal error: unknown result code" code))))
|
|
|
|
(define (yp-success? code)
|
|
(zero? code))
|
|
|
|
(define yp-unknown-key?
|
|
(let ((yp-unknown-key (lookup-shared-value "yp-error-key")))
|
|
(lambda (code)
|
|
(equal? yp-unknown-key code))))
|
|
|
|
(define yp-no-more-results?
|
|
(let ((yp-error-nomore (lookup-shared-value "yp-error-nomore")))
|
|
(lambda (code)
|
|
(equal? yp-error-nomore code))))
|
|
|
|
;;; condition hierachy
|
|
(define-condition-type 'yp-error '(error))
|
|
(define yp-error?
|
|
(condition-predicate 'yp-error))
|
|
|
|
(define-condition-type 'yp-communication-error '(yp-error))
|
|
(define yp-communication-error?
|
|
(condition-predicate 'yp-communication-error))
|
|
|
|
(define-condition-type 'yp-unknown-resource-error '(yp-error))
|
|
(define yp-unknown-resource-error?
|
|
(condition-predicate 'yp-unknown-resource-error))
|
|
|
|
;;; conditions
|
|
(define-condition-type 'yp-bad-arguments '(yp-error))
|
|
(define yp-bad-arguments?
|
|
(condition-predicate 'yp-bad-arguments))
|
|
|
|
(define-condition-type 'yp-bad-database '(yp-error))
|
|
(define yp-bad-database?
|
|
(condition-predicate 'yp-bad-database))
|
|
|
|
(define-condition-type 'yp-bad-domain '(yp-communication-error))
|
|
(define yp-binding-error?
|
|
(condition-predicate 'yp-bad-domain))
|
|
|
|
(define-condition-type 'yp-unknown-key '(yp-unknown-resource-error))
|
|
(define yp-unknown-key?
|
|
(condition-predicate 'yp-unknown-key))
|
|
|
|
(define-condition-type 'yp-unknown-map '(yp-unknown-resource-error))
|
|
(define yp-unknown-map?
|
|
(condition-predicate 'yp-unknown-map))
|
|
|
|
(define-condition-type 'yp-no-domain '(yp-communication-error))
|
|
(define yp-no-domain?
|
|
(condition-predicate 'yp-no-domain))
|
|
|
|
(define-condition-type 'yp-portmap-failure '(yp-communication-error))
|
|
(define yp-portmap-failure?
|
|
(condition-predicate 'yp-portmap-failure))
|
|
|
|
(define-condition-type 'yp-allocation-failure '(yp-error))
|
|
(define yp-allocation-failure?
|
|
(condition-predicate 'yp-allocation-failure))
|
|
|
|
(define-condition-type 'yp-rpc-failure '(yp-communication-error))
|
|
(define yp-rpc-failure?
|
|
(condition-predicate 'yp-rpc-failure))
|
|
|
|
(define-condition-type 'yp-bind-failure '(yp-communication-error))
|
|
(define yp-bind-failure?
|
|
(condition-predicate 'yp-bind-failure))
|
|
|
|
(define-condition-type 'yp-internal-error '(yp-error))
|
|
(define yp-internal-error?
|
|
(condition-predicate 'yp-internal-error))
|
|
|
|
(define-condition-type 'yp-server-error '(yp-communication-error))
|
|
(define yp-server-error?
|
|
(condition-predicate 'yp-server-error))
|
|
|
|
(define (yp-get-default-domain)
|
|
(receive (code domain)
|
|
(apply values (yp-get-default-domain-int))
|
|
(if (yp-success? code)
|
|
domain
|
|
(raise-yp-error code `(yp-get-default-domain domain ,domain)))))
|
|
|
|
(define (yp-bind . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(let ((code (yp-bind-int domain)))
|
|
(or (yp-success? code)
|
|
(raise-yp-error code `(yp-bind domain ,domain))))))
|
|
|
|
(define (yp-unbind . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(yp-unbind-int domain)
|
|
#t))
|
|
|
|
(define (yp-match map key . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code val)
|
|
(apply values (yp-match-int domain map key))
|
|
(cond
|
|
((yp-success? code) val)
|
|
((yp-unknown-key? code) #f)
|
|
(else
|
|
(raise-yp-error
|
|
code `(yp-match map ,map key ,key domain ,domain)))))))
|
|
|
|
(define (yp-order map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code val)
|
|
(apply values (yp-order-int domain map))
|
|
(if (yp-success? code)
|
|
val
|
|
(raise-yp-error code `(yp-order map ,map domain, domain))))))
|
|
|
|
(define (yp-master map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code val)
|
|
(apply values (yp-master-int domain map))
|
|
(if (yp-success? code)
|
|
val
|
|
(raise-yp-error code `(yp-master map ,map domain ,domain))))))
|
|
|
|
(define (yp-first map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code key val)
|
|
(apply values (yp-first-int domain map))
|
|
(if (yp-success? code)
|
|
(values key val)
|
|
(raise-yp-error code `(yp-first key ,key val ,val))))))
|
|
|
|
(define (yp-next map key . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (code key val)
|
|
(apply values (yp-next-int domain map key))
|
|
(cond
|
|
((yp-success? code)
|
|
(values key val))
|
|
((yp-no-more-results? code)
|
|
(values #f #f))
|
|
(else
|
|
(raise-yp-error code `(yp-next key ,key val ,val)))))))
|
|
|
|
(define (yp-map->list map . domain)
|
|
(let-optionals domain
|
|
((domain (yp-get-default-domain)))
|
|
(receive (key val) (yp-first map domain)
|
|
(let loop ((key key) (res (cons (cons key val) '())))
|
|
(receive (key val)
|
|
(yp-next map key domain)
|
|
(if val
|
|
(loop key (cons (cons key val) res))
|
|
res))))))
|
|
|
|
(define (yp-error-string yp-result)
|
|
(yp-error-string-int yp-result))
|
|
|
|
(import-lambda-definition yp-get-default-domain-int
|
|
()
|
|
"scsh_yp_getdefaultdomain")
|
|
|
|
(import-lambda-definition yp-bind-int
|
|
(domain)
|
|
"scsh_yp_bind")
|
|
|
|
(import-lambda-definition yp-unbind-int
|
|
(domain)
|
|
"scsh_yp_unbind")
|
|
|
|
(import-lambda-definition yp-error-string-int
|
|
(code)
|
|
"scsh_yp_errstring")
|
|
|
|
(import-lambda-definition yp-protocol-error
|
|
(code)
|
|
"scsh_yp_proterr")
|
|
|
|
(import-lambda-definition yp-match-int
|
|
(domain map key)
|
|
"scsh_yp_match")
|
|
|
|
(import-lambda-definition yp-order-int
|
|
(domain map)
|
|
"scsh_yp_order")
|
|
|
|
(import-lambda-definition yp-master-int
|
|
(domain map)
|
|
"scsh_yp_master")
|
|
|
|
(import-lambda-definition yp-first-int
|
|
(domain map)
|
|
"scsh_yp_first")
|
|
|
|
(import-lambda-definition yp-next-int
|
|
(domain map key)
|
|
"scsh_yp_next")
|