79 lines
2.0 KiB
Scheme
79 lines
2.0 KiB
Scheme
|
(library
|
||
|
|
(device-mapper ioctl)
|
||
|
|
|
||
|
|
(export dm-open
|
||
|
|
dm-close
|
||
|
|
with-dm
|
||
|
|
|
||
|
|
get-version)
|
||
|
|
|
||
|
|
(import (chezscheme)
|
||
|
|
(fmt fmt)
|
||
|
|
(srfi s8 receive)
|
||
|
|
(utils))
|
||
|
|
|
||
|
|
(define __ (load-shared-object "./device-mapper/dm-ioctl.so"))
|
||
|
|
|
||
|
|
(define (fail msg)
|
||
|
|
(raise
|
||
|
|
(condition
|
||
|
|
(make-error)
|
||
|
|
(make-message-condition msg))))
|
||
|
|
|
||
|
|
(define-ftype DMIoctlInterface
|
||
|
|
(struct
|
||
|
|
(fd int)))
|
||
|
|
|
||
|
|
(define open% (foreign-procedure "dm_open" () (* DMIoctlInterface)))
|
||
|
|
|
||
|
|
(define (dm-open)
|
||
|
|
(let ((ptr (open%)))
|
||
|
|
(if (ftype-pointer-null? ptr)
|
||
|
|
(fail "couldn't open ioctl interface (permissions?)")
|
||
|
|
ptr)))
|
||
|
|
|
||
|
|
(define dm-close
|
||
|
|
(foreign-procedure "dm_close" ((* DMIoctlInterface)) void))
|
||
|
|
|
||
|
|
(define-syntax with-dm
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ (name) b1 b2 ...)
|
||
|
|
(let ((name (dm-open)))
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda () #f)
|
||
|
|
(lambda () b1 b2 ...)
|
||
|
|
(lambda () (dm-close name)))))))
|
||
|
|
|
||
|
|
(define-record-type dm-version (fields major minor patch))
|
||
|
|
|
||
|
|
(define-ftype PtrU32 (* unsigned-32))
|
||
|
|
|
||
|
|
(define (get-version dm)
|
||
|
|
(define get
|
||
|
|
(foreign-procedure "dm_version" ((* DMIoctlInterface)
|
||
|
|
(* unsigned-32)
|
||
|
|
(* unsigned-32)
|
||
|
|
(* unsigned-32)) int))
|
||
|
|
|
||
|
|
(define (alloc-u32)
|
||
|
|
(make-ftype-pointer unsigned-32
|
||
|
|
(foreign-alloc (ftype-sizeof unsigned-32))))
|
||
|
|
|
||
|
|
(define (deref-u32 p)
|
||
|
|
(ftype-ref unsigned-32 () p))
|
||
|
|
|
||
|
|
(let ((major (alloc-u32))
|
||
|
|
(minor (alloc-u32))
|
||
|
|
(patch (alloc-u32)))
|
||
|
|
(get dm major minor patch)
|
||
|
|
(let ((r (make-dm-version (deref-u32 major)
|
||
|
|
(deref-u32 minor)
|
||
|
|
(deref-u32 patch))))
|
||
|
|
(foreign-free (ftype-pointer-address major))
|
||
|
|
(foreign-free (ftype-pointer-address minor))
|
||
|
|
(foreign-free (ftype-pointer-address patch))
|
||
|
|
r)))
|
||
|
|
|
||
|
|
|
||
|
|
)
|