#lang scheme
(require
(only-in srfi/1 unfold)
srfi/19
scheme/foreign
(only-in scheme/contract [-> ->/c]))
(unsafe!)
(define libapr
(ffi-lib "libapr-1"))
(define strerror
(get-ffi-obj "apr_strerror" libapr
(_fun [status : _int]
[buffer : (_bytes o size)] [size : _ulong = 256]
-> [message : _string/utf-8])))
(define-struct (exn:fail:apr exn:fail)
(status)
#:transparent)
(define (check-status source status)
(unless (= status 0)
(raise (make-exn:fail:apr
(format "~a: ~a" source (strerror status))
(current-continuation-marks)
status))))
(provide/contract
(struct (exn:fail:apr exn:fail)
([message string?]
[continuation-marks continuation-mark-set?]
[status exact-integer?])))
(provide*
(unsafe check-status))
(define initialize
(get-ffi-obj "apr_initialize" libapr
(_fun
-> [status : _int]
-> (check-status 'initialize status))))
(initialize)
(define pooled-pointer-tag
"pooled")
(define _pooled-pointer
(_cpointer/null pooled-pointer-tag _pointer
values
(λ (ptr)
(when ptr
(set-cpointer-tag! ptr
(list* pooled-pointer-tag (current-pool)
(remove pooled-pointer-tag
(let ([tag (cpointer-tag ptr)])
(if (pair? tag) tag (list tag)))))))
ptr)))
(define (pooled-pointer? obj)
(and (cpointer? obj)
(cpointer-has-tag? obj pooled-pointer-tag)))
(define (pointer-pool obj)
(cond
[(pooled-pointer? obj)
=> cadr]
[else
#f]))
(provide _pooled-pointer pooled-pointer? pointer-pool)
(define-cpointer-type _pool _pooled-pointer)
(provide _pool _pool/null pool?)
(define current-pool
(make-parameter #f))
(provide/contract
[current-pool (parameter/c (or/c pool? #f))])
(define make-pool
(local [(define make-pool*
(get-ffi-obj
"apr_pool_create_ex" libapr
(_fun [pool : (_ptr o _pool/null)] [parent : _pool/null]
[abort : _pointer = #f] [alloc : _pointer = #f]
-> [status : _int]
-> (begin
(check-status 'make-pool status)
pool))))
(define pool-destroy
(get-ffi-obj
"apr_pool_destroy" libapr
(_fun [pool : _pool]
-> _void)))]
(λ ([parent (current-pool)])
(nest [(parameterize-break #f)
(parameterize ([current-pool parent]))]
(let ([pool (make-pool* parent)])
(register-finalizer pool pool-destroy)
pool)))))
(provide make-pool)
(define-syntax wrapper-with-pool
(syntax-rules ()
[(wrapper-with-pool lambda-list (proc-expr arg-exprs ...))
(let ([proc proc-expr])
(λ lambda-list
(parameterize ([current-pool (make-pool)])
(proc arg-exprs ...))))]))
(provide wrapper-with-pool)
(define bytes-copy/pool
(get-ffi-obj
"apr_pstrmemdup" libapr
(_fun [pool : _pool = (current-pool)]
[bytes : _bytes] [length : _ulong = (bytes-length bytes)]
-> [copy : _pooled-pointer])))
(provide bytes-copy/pool)
(define-cstruct _array-header
([pool _pool]
[element-size _int]
[element-count _int]
[allocation-count _int]
[elements _pointer]))
(define (array-header->cvector header type)
(let ([element-size (array-header-element-size header)])
(unless (= (ctype-sizeof type) element-size)
(raise-type-error 'array-header->cvector
(format "ctype of size ~a" element-size)
type)))
(make-cvector* (array-header-elements header)
type
(array-header-element-count header)))
(provide*
_array-header _array-header-pointer _array-header-pointer/null
array-header? (unsafe make-array-header)
(unsafe array-header-pool) array-header-element-size
array-header-element-count array-header-allocation-count
array-header-elements (unsafe array-header->cvector))
(define-cpointer-type _apr-hash _pooled-pointer)
(define-cpointer-type _apr-hash-index _pooled-pointer)
(provide
_apr-hash _apr-hash/null apr-hash?
_apr-hash-index _apr-hash-index/null apr-hash-index?)
(define apr-hash-first
(wrapper-with-pool (hash)
((get-ffi-obj
"apr_hash_first" libapr
(_fun [pool : _pool = (current-pool)]
[hash : _apr-hash]
-> [index : _apr-hash-index/null]))
hash)))
(define apr-hash-next
(local [(define apr-hash-next*
(get-ffi-obj
"apr_hash_next" libapr
(_fun [index : _apr-hash-index]
-> [next-index : _apr-hash-index/null])))]
(λ (index)
(parameterize ([current-pool (pointer-pool index)])
(apr-hash-next* index)))))
(define apr-hash-this
(get-ffi-obj
"apr_hash_this" libapr
(_fun [index : _apr-hash-index]
[key : (_ptr o _pointer)] [length : (_ptr o _int)]
[value : (_ptr o _pointer)]
-> _void
-> (values (bytes-copy (make-sized-byte-string key length))
value))))
(define (apr-hash->keys hash)
(unfold
not
(λ (index)
(let-values ([(key value) (apr-hash-this index)])
key))
apr-hash-next
(apr-hash-first hash)))
(provide apr-hash->keys)
(define (apr-time->time-utc time)
(let-values ([(seconds micros) (quotient/remainder time #e1e6)])
(make-time time-utc (* micros #e1e3) seconds)))
(define (time-utc->apr-time time)
(unless (eq? (time-type time) time-utc)
(raise-type-error 'time-utc->apr-time "time-utc" time))
(let ([seconds (time-second time)]
[nanos (time-nanosecond time)])
(+ (* seconds #e1e6) (quotient nanos #e1e3))))
(provide/contract
[apr-time->time-utc (->/c exact-integer? time?)]
[time-utc->apr-time (->/c time? exact-integer?)])
(define-unsafer unsafe-apr!)