#lang scheme
(require
srfi/31
scheme/foreign
(only-in scheme/contract [-> ->/c])
"apr.ss")
(unsafe!)
(define libsvn-subr
(ffi-lib "libsvn_subr-1"))
(define-cstruct _error
([status _int]
[message _string/utf-8]
[child _error-pointer/null]
[pool _pool]
[file _string/utf-8]
[line _long]))
(provide
(rename-out [_error-pointer _error] [_error-pointer/null _error/null])
error?)
(define-struct (exn:fail:svn exn:fail)
(status
child
location)
#:transparent
#:property prop:exn:srclocs
(rec (exn:fail:svn-srclocs exn)
(cons (exn:fail:svn-location exn)
(cond
[(exn:fail:svn-child exn)
=> exn:fail:svn-srclocs]
[else
'()]))))
(define error-clear
(get-ffi-obj
"svn_error_clear" libsvn-subr
(_fun (error : _error-pointer/null) -> _void)))
(define (check-error source error)
(dynamic-wind
void
(λ ()
(when error
(raise
((rec (error->exn:fail:svn error)
(make-exn:fail:svn
(format "~a: ~a" source (error-message error))
(current-continuation-marks)
(error-status error)
(cond
[(error-child error)
=> error->exn:fail:svn]
[else
#f])
(let ([file (error-file error)]
[line (error-line error)])
(if file
(make-srcloc file (if (> line 0) line #f)
#f #f #f)
#f))))
error))))
(λ ()
(error-clear error))))
(provide/contract
(struct (exn:fail:svn exn:fail)
([message string?]
[continuation-marks continuation-mark-set?]
[status exact-integer?]
[child (or/c exn:fail:svn? #f)]
[location (or/c srcloc? #f)])))
(provide*
(unsafe check-error))
(define-cstruct _svn-string
([data _pointer]
[length _ulong]))
(define (bytes->svn-string bytes)
(if bytes
(make-svn-string bytes (bytes-length bytes))
#f))
(define (svn-string->bytes str)
(if str
(bytes-copy
(make-sized-byte-string (svn-string-data str)
(svn-string-length str)))
#f))
(define-cstruct _svn-stringbuf
([pool _pool/null]
[data _pointer]
[length _ulong]
[allocation-length _ulong]))
(define (bytes->svn-stringbuf bytes)
(if bytes
(make-svn-stringbuf #f bytes (bytes-length bytes) (bytes-length bytes))
#f))
(define (svn-stringbuf->bytes str)
(if str
(bytes-copy
(make-sized-byte-string (svn-stringbuf-data str)
(svn-stringbuf-length str)))
#f))
(provide*
_svn-string _svn-string-pointer _svn-string-pointer/null svn-string?
(unsafe svn-string-tag)
(unsafe bytes->svn-string) (unsafe svn-string->bytes)
_svn-stringbuf _svn-stringbuf-pointer _svn-stringbuf-pointer/null svn-stringbuf?
(unsafe svn-stringbuf-tag)
(unsafe bytes->svn-stringbuf) (unsafe svn-stringbuf->bytes))
(define-cpointer-type _stream _pooled-pointer)
(provide _stream _stream/null stream?)
(define stream-read
(get-ffi-obj
"svn_stream_read" libsvn-subr
(_fun [stream : _stream]
[buffer : _bytes] [length : (_ptr io _ulong) = (bytes-length buffer)]
-> [error : _error-pointer/null]
-> (begin
(check-error 'stream-read error)
length))))
(define stream-write
(get-ffi-obj
"svn_stream_write" libsvn-subr
(_fun [stream : _stream]
[buffer : _bytes] [length : (_ptr io _ulong) = (bytes-length buffer)]
-> [error : _error-pointer/null]
-> (begin
(check-error 'stream-write error)
length))))
(define stream-close
(get-ffi-obj
"svn_stream_close" libsvn-subr
(_fun [stream : _stream]
-> [error : _error-pointer/null]
-> (check-error 'stream-close error))))
(define (stream->input-port name stream)
(make-input-port name
(λ (bytes)
(let ([length (stream-read stream bytes)])
(if (> length 0)
length
eof)))
#f
(λ ()
(stream-close stream))))
(define (stream->output-port name stream)
(make-output-port name
always-evt
(λ (bytes start end dont-block? enable-breaks?)
(stream-write stream (subbytes bytes start end)))
(λ ()
(stream-close stream))))
(provide stream->input-port stream->output-port)
(define genuuid
(wrapper-with-pool ()
((get-ffi-obj
"svn_uuid_generate" libsvn-subr
(_fun [pool : _pool = (current-pool)]
-> _bytes)))))
(provide genuuid)
(define-unsafer unsafe-subr!)