#lang scheme
(require
srfi/17
srfi/19
scheme/foreign
(only-in scheme/contract [-> ->/c])
"apr.ss"
"subr.ss")
(unsafe!)
(unsafe-apr!)
(unsafe-subr!)
(define libsvn-fs
(ffi-lib "libsvn_fs-1"))
(define libsvn-delta
(ffi-lib "libsvn_delta-1"))
(define global-pool
(make-pool #f))
(define initialize
(get-ffi-obj
"svn_fs_initialize" libsvn-fs
(_fun [pool : _pool]
-> [error : _error/null]
-> (check-error 'initialize error))))
(initialize global-pool)
(define-cpointer-type _fs _pooled-pointer)
(provide _fs _fs/null fs?)
(define fs-create
(wrapper-with-pool (path)
((get-ffi-obj
"svn_fs_create" libsvn-fs
(_fun [fs : (_ptr o _fs/null)] [path : _path]
[config : _pointer = #f] [pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-create error)
fs)))
(path->complete-path path))))
(define fs-open
(wrapper-with-pool (path)
((get-ffi-obj
"svn_fs_open" libsvn-fs
(_fun [fs : (_ptr o _fs/null)] [path : _path]
[config : _pointer = #f] [pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-open error)
fs)))
(path->complete-path path))))
(define fs-hotcopy
(wrapper-with-pool (src dst clean?)
((get-ffi-obj
"svn_fs_hotcopy" libsvn-fs
(_fun [src : _path] [dst : _path]
[clean? : _bool]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-hotcopy error)))
(path->complete-path src) (path->complete-path dst) clean?)))
(define fs-delete
(wrapper-with-pool (path)
((get-ffi-obj
"svn_fs_delete_fs" libsvn-fs
(_fun [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-delete error)))
(path->complete-path path))))
(provide fs-create fs-open fs-hotcopy fs-delete)
(define fs-type
(wrapper-with-pool (path)
((get-ffi-obj
"svn_fs_type" libsvn-fs
(_fun [type : (_ptr o _symbol)] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-type error)
type)))
(path->complete-path path))))
(define fs-path
(wrapper-with-pool (fs)
((get-ffi-obj
"svn_fs_path" libsvn-fs
(_fun [fs : _fs]
[pool : _pool = (current-pool)]
-> [path : _path]))
fs)))
(define set-fs-uuid!
(wrapper-with-pool (fs uuid)
((get-ffi-obj
"svn_fs_set_uuid" libsvn-fs
(_fun [fs : _fs]
[uuid : _bytes]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'set-fs-uuid! error)))
fs uuid)))
(define fs-uuid
(getter-with-setter
(wrapper-with-pool (fs)
((get-ffi-obj
"svn_fs_get_uuid" libsvn-fs
(_fun [fs : _fs]
[uuid : (_ptr o _bytes)]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-uuid error)
uuid)))
fs))
set-fs-uuid!))
(provide fs-type fs-path fs-uuid set-fs-uuid!)
(define-cpointer-type _fs-access _pooled-pointer)
(provide _fs-access _fs-access/null fs-access?)
(define make-fs-access
(wrapper-with-pool (username)
((get-ffi-obj
"svn_fs_create_access" libsvn-fs
(_fun [context : (_ptr o _fs-access/null)]
[username : _string/utf-8]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'make-fs-access error)
context)))
username)))
(define fs-access-username
(get-ffi-obj
"svn_fs_access_get_username" libsvn-fs
(_fun [username : (_ptr o _string/utf-8)]
[context : _fs-access]
-> [error : _error/null]
-> (begin
(check-error 'fs-access-username error)
username))))
(define fs-access-add-lock-token!
(local [(define fs-access-add-lock-token*
(get-ffi-obj
"svn_fs_access_add_lock_token" libsvn-fs
(_fun [context : _fs-access] [token : _pointer]
-> [error : _error/null]
-> (check-error 'fs-access-add-lock-token! error))))]
(λ (context token)
(parameterize ([current-pool (pointer-pool context)])
(fs-access-add-lock-token* context (bytes-copy/pool token))))))
(define set-fs-access!
(get-ffi-obj
"svn_fs_set_access" libsvn-fs
(_fun [fs : _fs] [context : _fs-access/null]
-> [error : _error/null]
-> (check-error 'set-fs-access! error))))
(define fs-access
(getter-with-setter
(local [(define fs-access*
(get-ffi-obj
"svn_fs_get_access" libsvn-fs
(_fun [context : (_ptr o _fs-access/null)] [fs : _fs]
-> [error : _error/null]
-> (begin
(check-error 'fs-access error)
context))))]
(λ (fs)
(parameterize ([current-pool (pointer-pool fs)])
(fs-access* fs))))
set-fs-access!))
(provide
make-fs-access fs-access-username fs-access-add-lock-token!
fs-access set-fs-access!)
(define fs-youngest-rev
(wrapper-with-pool (fs)
((get-ffi-obj
"svn_fs_youngest_rev" libsvn-fs
(_fun [rev : (_ptr o _long)]
[fs : _fs]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-youngest-rev error)
rev)))
fs)))
(define set-fs-rev-prop!
(wrapper-with-pool (fs rev prop-name value)
((get-ffi-obj
"svn_fs_change_rev_prop" libsvn-fs
(_fun [fs : _fs] [rev : _long]
[prop-name : _symbol] [value : _svn-string-pointer/null]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'set-fs-rev-prop! error)))
fs rev prop-name (bytes->svn-string value))))
(define fs-rev-prop
(getter-with-setter
(wrapper-with-pool (fs rev prop-name)
((get-ffi-obj
"svn_fs_revision_prop" libsvn-fs
(_fun [value : (_ptr o _svn-string-pointer/null)]
[fs : _fs] [rev : _long]
[prop-name : _symbol]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-rev-prop error)
(svn-string->bytes value))))
fs rev prop-name))
set-fs-rev-prop!))
(define fs-list-rev-props
(wrapper-with-pool (fs rev)
((get-ffi-obj
"svn_fs_revision_proplist" libsvn-fs
(_fun [hash : (_ptr o _apr-hash/null)]
[fs : _fs] [rev : _long]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-list-rev-props error)
(map (compose string->symbol bytes->string/utf-8)
(apr-hash->keys hash)))))
fs rev)))
(define fs-deltify-rev
(wrapper-with-pool (fs rev)
((get-ffi-obj
"svn_fs_deltify_revision" libsvn-fs
(_fun [fs : _fs] [rev : _long]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-deltify-rev error)))
fs rev)))
(provide
fs-youngest-rev fs-rev-prop set-fs-rev-prop! fs-list-rev-props fs-deltify-rev)
(define-cstruct _lock
([path _path]
[token _bytes]
[owner _string/utf-8]
[comment _string/utf-8]
[dav-comment? _bool]
[creation-time _int64]
[expiration-time _int64]))
(define-struct lock-info
(path token owner comment creation-time expiration-time)
#:transparent)
(define (lock->lock-info lock)
(make-lock-info
(lock-path lock)
(lock-token lock)
(lock-owner lock)
(lock-comment lock)
(apr-time->time-utc (lock-creation-time lock))
(let ([micros (lock-expiration-time lock)])
(if (= micros 0) #f (apr-time->time-utc micros)))))
(provide/contract
(struct lock-info
([path path?]
[token bytes?]
[owner string?]
[comment (or/c string? #f)]
[creation-time time?]
[expiration-time (or/c time? #f)])))
(define fs-lock!
(wrapper-with-pool (fs path
#:token [token #f]
#:comment [comment #f]
#:expiration-time [expiration-time #f]
#:current-rev [current-rev #f]
#:steal [steal? #f])
((get-ffi-obj
"svn_fs_lock" libsvn-fs
(_fun [lock : (_ptr o _lock-pointer/null)]
[fs : _fs] [path : _path] [token : _bytes]
[comment : _string/utf-8] [dav-comment? : _bool = #f]
[expiration-time : _int64]
[current-rev : _long] [steal? : _bool]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-lock! error)
(lock->lock-info lock))))
fs path token comment
(if expiration-time
(time-utc->apr-time
(let ([type (time-type expiration-time)])
(cond
[(eq? type time-utc)
expiration-time]
[(eq? type time-duration)
(add-duration! (current-time) expiration-time)]
[else
(raise-type-error 'fs-lock! "time-utc or time-duration" expiration-time)])))
0)
(or current-rev -1) steal?)))
(define fs-unlock!
(wrapper-with-pool (fs path token)
((get-ffi-obj
"svn_fs_unlock" libsvn-fs
(_fun [fs : _fs] [path : _path] [token : _bytes]
[break? : _bool = (not token)]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-unlock! error)))
fs path token)))
(define (call-with-fs-lock fs path thunk
#:token [token #f]
#:comment [comment #f]
#:expiration-time [expiration-time #f]
#:current-rev [current-rev #f]
#:steal [steal? #f])
(dynamic-wind
(λ ()
(let ([lock (fs-lock! fs path
#:token token
#:comment comment
#:expiration-time expiration-time
#:current-rev current-rev
#:steal steal?)])
(set! token (lock-info-token lock))
(fs-access-add-lock-token! (fs-access fs) token)))
thunk
(λ ()
(fs-unlock! fs path token))))
(define fs-lock-info
(wrapper-with-pool (fs path)
((get-ffi-obj
"svn_fs_get_lock" libsvn-fs
(_fun [lock : (_ptr o _lock-pointer/null)]
[fs : _fs] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-lock-info error)
(cond
[lock
=> lock->lock-info]
[else
#f]))))
fs path)))
(define fs-list-locks
(local [(define fs-list-locks*
(get-ffi-obj
"svn_fs_get_locks" libsvn-fs
(_fun [fs : _fs] [path : _path]
[proc : (_fun [baton : _pointer]
[lock : _lock-pointer]
[pool : _pool]
-> [error : _error/null])]
[baton : _pointer = #f]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-list-locks error))))]
(λ (fs path)
(let ([locks '()])
(parameterize ([current-pool (make-pool)])
(fs-list-locks*
fs path
(λ (baton lock pool)
(set! locks (cons (lock->lock-info lock) locks))
#f)))
locks))))
(provide
fs-lock! fs-unlock! call-with-fs-lock fs-lock-info fs-list-locks)
(define-cpointer-type _fs-txn _pooled-pointer)
(provide _fs-txn _fs-txn/null fs-txn?)
(define fs-begin-txn
(wrapper-with-pool (fs rev)
((get-ffi-obj
"svn_fs_begin_txn2" libsvn-fs
(_fun [txn : (_ptr o _fs-txn/null)]
[fs : _fs] [rev : _long]
[flags : _uint32 = 3]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-begin-txn error)
txn)))
fs rev)))
(define fs-open-txn
(wrapper-with-pool (fs txn-name)
((get-ffi-obj
"svn_fs_open_txn" libsvn-fs
(_fun [txn : (_ptr o _fs-txn/null)]
[fs : _fs] [txn-name : _bytes]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-open-txn error)
txn)))
fs txn-name)))
(define fs-commit-txn
(wrapper-with-pool (txn)
((get-ffi-obj
"svn_fs_commit_txn" libsvn-fs
(_fun [conflict : _pointer = #f]
[new-rev : (_ptr o _long)]
[txn : _fs-txn]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-commit-txn error)
new-rev)))
txn)))
(define fs-abort-txn
(wrapper-with-pool (txn)
((get-ffi-obj
"svn_fs_abort_txn" libsvn-fs
(_fun [txn : _fs-txn]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-abort-txn error)))
txn)))
(define fs-purge-txn
(wrapper-with-pool (fs txn-name)
((get-ffi-obj
"svn_fs_purge_txn" libsvn-fs
(_fun [fs : _fs]
[txn-name : _bytes]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-purge-txn error)))
fs txn-name)))
(define fs-txn-name
(wrapper-with-pool (txn)
((get-ffi-obj
"svn_fs_txn_name" libsvn-fs
(_fun [txn-name : (_ptr o _bytes)]
[txn : _fs-txn]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-txn-name error)
txn-name)))
txn)))
(define fs-txn-base-rev
(get-ffi-obj
"svn_fs_txn_base_revision" libsvn-fs
(_fun [txn : _fs-txn]
-> [rev : _long])))
(define set-fs-txn-prop!
(wrapper-with-pool (txn prop-name value)
((get-ffi-obj
"svn_fs_change_txn_prop" libsvn-fs
(_fun [txn : _fs-txn] [prop-name : _symbol]
[value : _svn-string-pointer/null]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'set-fs-txn-prop! error)))
txn prop-name (bytes->svn-string value))))
(define fs-txn-prop
(getter-with-setter
(wrapper-with-pool (txn prop-name)
((get-ffi-obj
"svn_fs_txn_prop" libsvn-fs
(_fun [value : (_ptr o _svn-string-pointer/null)]
[txn : _fs-txn] [prop-name : _symbol]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-txn-prop error)
(svn-string->bytes value))))
txn prop-name))
set-fs-txn-prop!))
(define fs-list-txn-props
(wrapper-with-pool (txn)
((get-ffi-obj
"svn_fs_txn_proplist" libsvn-fs
(_fun [hash : (_ptr o _apr-hash/null)]
[txn : _fs-txn]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-list-txn-props error)
(map (compose string->symbol bytes->string/utf-8)
(apr-hash->keys hash)))))
txn)))
(define fs-list-txns
(wrapper-with-pool (fs)
((get-ffi-obj
"svn_fs_list_transactions" libsvn-fs
(_fun [names : (_ptr o _array-header-pointer/null)]
[fs : _fs]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-list-txns error)
(cvector->list (array-header->cvector names _bytes)))))
fs)))
(define (call-with-fs-txn fs rev proc)
(let* ([txn (fs-begin-txn fs rev)])
(apply
values
(dynamic-wind
void
(λ ()
(let* ([results (call-with-values
(λ ()
(proc txn))
(λ (first-result . more-results)
(if (void? first-result)
more-results
(cons first-result more-results))))]
[new-rev (fs-commit-txn txn)])
(set! txn #f)
(cons new-rev results)))
(λ ()
(when txn
(fs-abort-txn txn)
(set! txn #f)))))))
(provide
fs-begin-txn fs-open-txn fs-commit-txn fs-abort-txn fs-purge-txn
fs-txn-name fs-txn-base-rev fs-txn-prop set-fs-txn-prop!
fs-list-txn-props fs-list-txns call-with-fs-txn)
(define-cpointer-type _fs-root _pooled-pointer)
(provide _fs-root _fs-root/null fs-root?)
(define fs-rev-root
(wrapper-with-pool (fs rev)
((get-ffi-obj
"svn_fs_revision_root" libsvn-fs
(_fun [root : (_ptr o _fs-root/null)]
[fs : _fs] [rev : _long]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-rev-root error)
root)))
fs rev)))
(define fs-rev-root?
(get-ffi-obj
"svn_fs_is_revision_root" libsvn-fs
(_fun [root : _fs-root]
-> _bool)))
(define fs-rev-root-rev
(get-ffi-obj
"svn_fs_revision_root_revision" libsvn-fs
(_fun [root : _fs-root]
-> _long)))
(define fs-txn-root
(wrapper-with-pool (txn)
((get-ffi-obj
"svn_fs_txn_root" libsvn-fs
(_fun [root : (_ptr o _fs-root/null)]
[txn : _fs-txn]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-txn-root error)
root)))
txn)))
(define fs-txn-root?
(get-ffi-obj
"svn_fs_is_txn_root" libsvn-fs
(_fun [root : _fs-root]
-> _bool)))
(define fs-txn-root-name
(wrapper-with-pool (root)
((get-ffi-obj
"svn_fs_txn_root_name" libsvn-fs
(_fun [root : _fs-root]
[pool : _pool = (current-pool)]
-> _bytes))
root)))
(define fs-root-fs
(local [(define fs-root-fs*
(get-ffi-obj
"svn_fs_root_fs" libsvn-fs
(_fun [root : _fs-root]
-> [fs : _fs])))]
(λ (root)
(parameterize ([current-pool (pointer-pool root)])
(fs-root-fs* root)))))
(provide
fs-rev-root fs-rev-root? fs-rev-root-rev
fs-txn-root fs-txn-root? fs-txn-root-name fs-root-fs)
(define fs-make-directory
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_make_dir" libsvn-fs
(_fun [root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-make-directory error)))
root path)))
(define fs-make-file*
(get-ffi-obj
"svn_fs_make_file" libsvn-fs
(_fun [root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-make-file error))))
(define (fs-make-file root path)
(parameterize ([current-pool (make-pool)])
(fs-make-file* root path)))
(define fs-copy-node
(wrapper-with-pool (src-root src-path tgt-root tgt-path)
((get-ffi-obj
"svn_fs_copy" libsvn-fs
(_fun [src-root : _fs-root] [src-path : _path]
[tgt-root : _fs-root] [tgt-path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-copy-node error)))
src-root src-path tgt-root tgt-path)))
(define fs-rev-link-node
(wrapper-with-pool (src-root tgt-root path)
((get-ffi-obj
"svn_fs_revision_link" libsvn-fs
(_fun [src-root : _fs-root] [tgt-root : _fs-root]
[path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-rev-link-node error)))
src-root tgt-root path)))
(define fs-merge-nodes
(wrapper-with-pool (src-root src-path tgt-root tgt-path ancestor-root ancestor-path)
((get-ffi-obj
"svn_fs_merge" libsvn-fs
(_fun [conflict : _pointer = #f]
[src-root : _fs-root] [src-path : _path]
[tgt-root : _fs-root] [tgt-path : _path]
[ancestor-root : _fs-root] [ancestor-path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-merge-nodes error)))
src-root src-path tgt-root tgt-path
ancestor-root ancestor-path)))
(define fs-delete-node
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_delete" libsvn-fs
(_fun [root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'fs-delete-node error)))
root path)))
(provide
fs-make-directory fs-make-file fs-copy-node fs-rev-link-node
fs-merge-nodes fs-delete-node)
(define _fs-node-kind
(_enum '(none file dir unknown)))
(provide _fs-node-kind)
(define fs-node-kind
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_check_path" libsvn-fs
(_fun [kind : (_ptr o _fs-node-kind)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-kind error)
kind)))
root path)))
(define fs-node-directory?
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_is_dir" libsvn-fs
(_fun [ok? : (_ptr o _bool)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-directory? error)
ok?)))
root path)))
(define fs-node-file?
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_is_file" libsvn-fs
(_fun [ok? : (_ptr o _bool)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-file? error)
ok?)))
root path)))
(define fs-node-created-rev
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_node_created_rev" libsvn-fs
(_fun [rev : (_ptr o _long)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-created-rev error)
(if (>= rev 0) rev #f))))
root path)))
(define fs-node-created-path
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_node_created_path" libsvn-fs
(_fun [created-path : (_ptr o _path)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-created-path error)
created-path)))
root path)))
(define fs-node-copied-from
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_copied_from" libsvn-fs
(_fun [copied-rev : (_ptr o _long)]
[copied-path : (_ptr o _path)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-copied-from error)
(values (if (>= copied-rev 0) copied-rev #f)
copied-path))))
root path)))
(define fs-node-closest-copy
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_closest_copy" libsvn-fs
(_fun [copied-root : (_ptr o _fs-root/null)]
[copied-path : (_ptr o _path)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-closest-copy error)
(values copied-root
copied-path))))
root path)))
(define fs-directory-list
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_dir_entries" libsvn-fs
(_fun [hash : (_ptr o _apr-hash/null)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-directory-list error)
(map bytes->path-element (apr-hash->keys hash)))))
root path)))
(define fs-file-length
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_file_length" libsvn-fs
(_fun [length : (_ptr o _int64)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-file-length error)
length)))
root path)))
(define fs-file-contents-changed?
(wrapper-with-pool (src-root src-path tgt-root tgt-path)
((get-ffi-obj
"svn_fs_contents_changed" libsvn-fs
(_fun [changed? : (_ptr o _bool)]
[src-root : _fs-root] [src-path : _path]
[tgt-root : _fs-root] [tgt-path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-file-contents-changed? error)
changed?)))
src-root src-path tgt-root tgt-path)))
(provide
fs-node-kind fs-node-directory? fs-node-file?
fs-node-created-rev fs-node-created-path
fs-node-copied-from fs-node-closest-copy
fs-directory-list fs-file-length fs-file-contents-changed?)
(define set-fs-node-prop!
(wrapper-with-pool (root path prop-name value)
((get-ffi-obj
"svn_fs_change_node_prop" libsvn-fs
(_fun [root : _fs-root] [path : _path]
[prop-name : _symbol]
[value : _svn-string-pointer/null]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (check-error 'set-fs-node-prop! error)))
root path prop-name (bytes->svn-string value))))
(define fs-node-prop
(getter-with-setter
(wrapper-with-pool (root path prop-name)
((get-ffi-obj
"svn_fs_node_prop" libsvn-fs
(_fun [value : (_ptr o _svn-string-pointer/null)]
[root : _fs-root] [path : _path]
[prop-name : _symbol]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-prop error)
(svn-string->bytes value))))
root path prop-name))
set-fs-node-prop!))
(define fs-list-node-props
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_node_proplist" libsvn-fs
(_fun [hash : (_ptr o _apr-hash/null)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-list-node-props error)
(map (compose string->symbol bytes->string/utf-8)
(apr-hash->keys hash)))))
root path)))
(provide fs-node-prop set-fs-node-prop! fs-list-node-props)
(define-cpointer-type _fs-history _pooled-pointer)
(provide _fs-history _fs-history/null fs-history?)
(define fs-node-history
(wrapper-with-pool (root path)
((get-ffi-obj
"svn_fs_node_history" libsvn-fs
(_fun [history : (_ptr o _fs-history/null)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-node-history error)
history)))
root path)))
(define fs-history-prev
(wrapper-with-pool (history cross-copies?)
((get-ffi-obj
"svn_fs_history_prev" libsvn-fs
(_fun [prev-history : (_ptr o _fs-history/null)]
[history : _fs-history] [cross-copies? : _bool]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-history-prev error)
prev-history)))
history cross-copies?)))
(define fs-history-location
(wrapper-with-pool (history)
((get-ffi-obj
"svn_fs_history_location" libsvn-fs
(_fun [path : (_ptr o _path)] [rev : (_ptr o _long)]
[history : _fs-history]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-history-location error)
(values rev path))))
history)))
(provide fs-node-history fs-history-prev fs-history-location)
(define-cpointer-type _window-handler)
(define-cpointer-type _baton _pooled-pointer)
(define txdelta-target-push*
(get-ffi-obj
"svn_txdelta_target_push" libsvn-delta
(_fun [handler : _window-handler]
[baton : _baton/null]
[source : _stream]
[pool : _pool = (current-pool)]
-> [target : _stream])))
(define fs-file-contents*
(get-ffi-obj
"svn_fs_file_contents" libsvn-fs
(_fun [stream : (_ptr o _stream/null)]
[root : _fs-root] [path : _path]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-open-input-file error)
stream))))
(define fs-apply-text*
(get-ffi-obj
"svn_fs_apply_text" libsvn-fs
(_fun [stream : (_ptr o _stream/null)]
[root : _fs-root] [path : _path]
[base-checksum : _bytes]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-open-output-file error)
stream))))
(define fs-apply-textdelta*
(get-ffi-obj
"svn_fs_apply_textdelta" libsvn-fs
(_fun [handler : (_ptr o _window-handler/null)]
[baton : (_ptr o _baton/null)]
[root : _fs-root] [path : _path]
[base-checksum : _bytes]
[result-checksum : _bytes]
[pool : _pool = (current-pool)]
-> [error : _error/null]
-> (begin
(check-error 'fs-open-output-file error)
(values handler baton)))))
(define (fs-apply-push* root path base-checksum result-checksum)
(let-values ([(handler baton) (fs-apply-textdelta* root path
base-checksum
result-checksum)])
(txdelta-target-push* handler baton (fs-file-contents* root path))))
(define (fs-open-input-file root path)
(nest [(let ([path (build-path path)]))
(parameterize ([current-pool (make-pool)]))]
(stream->input-port path (fs-file-contents* root path))))
(define (fs-open-output-file root path
#:deltify [deltify? #t]
#:base-checksum [base-checksum #f]
#:result-checksum [result-checksum #f])
(nest [(let ([path (build-path path)]))
(parameterize ([current-pool (make-pool)]))]
(stream->output-port
path
(if deltify?
(fs-apply-push* root path base-checksum result-checksum)
(fs-apply-text* root path result-checksum)))))
(provide fs-open-input-file fs-open-output-file)
(define (call-with-fs-input-file root path proc)
(let* ([in (fs-open-input-file root path)]
[results (call-with-values
(λ ()
(proc in))
list)])
(close-input-port in)
(apply values results)))
(define (call-with-fs-output-file root path proc
#:deltify [deltify? #t]
#:base-checksum [base-checksum #f]
#:result-checksum [result-checksum #f])
(let* ([out (fs-open-output-file root path
#:deltify deltify?
#:base-checksum base-checksum
#:result-checksum result-checksum)]
[results (call-with-values
(λ ()
(proc out))
list)])
(close-output-port out)
(apply values results)))
(define (call-with-fs-input-file* root path proc)
(let ([in (fs-open-input-file root path)])
(dynamic-wind
void
(λ ()
(proc in))
(λ ()
(close-input-port in)))))
(define (call-with-fs-output-file* root path proc
#:deltify [deltify? #t]
#:base-checksum [base-checksum #f]
#:result-checksum [result-checksum #f])
(let ([out (fs-open-output-file root path
#:deltify deltify?
#:base-checksum base-checksum
#:result-checksum result-checksum)])
(dynamic-wind
void
(λ ()
(proc out))
(λ ()
(close-output-port out)))))
(define (with-fs-input-from-file root path thunk)
(call-with-fs-input-file*
root path
(λ (in)
(parameterize ([current-input-port in])
(thunk)))))
(define (with-fs-output-to-file root path thunk
#:deltify [deltify? #t]
#:base-checksum [base-checksum #f]
#:result-checksum [result-checksum #f])
(call-with-fs-output-file*
root path
#:deltify deltify?
#:base-checksum base-checksum
#:result-checksum result-checksum
(λ (out)
(parameterize ([current-output-port out])
(thunk)))))
(provide
call-with-fs-input-file call-with-fs-output-file
call-with-fs-input-file* call-with-fs-output-file*
with-fs-input-from-file with-fs-output-to-file)