[functional-tests] (device-mapper targets)

functional-tests/device-mapper/ioctl.scm

@@ -194,11 +194,15 @@
             (map foreign-free acc)
             (loop (ftype-ref Target (next) t) (cons t acc)))))
 
+  ;; targets should be dlambdas with 'size, 'type and 'format methods
   (define (load-table dm name targets)
     (define load
       (foreign-procedure "dm_load" ((* DMIoctlInterface) string (* Target)) int))
 
-    (let* ((ctargets (build-c-targets targets))
+    (define (dlambda->target t)
+      (make-target (t 'size) (t 'type) (t 'format)))
+
+    (let* ((ctargets (build-c-targets (map dlambda->target targets)))
            (r (load dm name ctargets)))
       (free-c-targets ctargets)
       (unless (zero? r)

functional-tests/device-mapper/targets.scm

@@ -0,0 +1,36 @@
+(library
+  (device-mapper targets)
+
+  (export linear-target)
+
+  (import (chezscheme)
+          (fmt fmt)
+          (list-utils))
+
+  (define-record-type segment
+    (fields (mutable dev) (mutable begin) (mutable end)))
+
+  (define (segment-size s)
+          (- (segment-end s)
+             (segment-begin s)))
+
+  (define (join docs)
+          (cat (intersperse (dsp " ") docs)))
+
+  (define (format-segment s)
+          (join (dsp (segment-dev s))))
+
+  (define (linear-target seg)
+    (dlambda
+      (type () 'linear)
+      (size () (segment-size seg))
+      (format () (fmt #f (format-segment s)))))
+
+  (define (stripe-target segments)
+    (unless (apply = (map segment-size segments))
+            (fail "stripe segments must all be the same size")
+    (dlambda
+      (type () 'stripe)
+      (size () (fold-right + 0 (map segment-size segments)))
+      (format () (fmt #f (join (map format-segment segments)))))))
+  )

functional-tests/fail.scm

@@ -0,0 +1,7 @@
+(library
+  (fail)
+
+  (define (fail msg)
+    (raise (condition
+             (make-error)
+             (make-message-condition msg)))))

functional-tests/process.scm

@@ -6,6 +6,7 @@
           run-fail)
 
   (import (chezscheme)
+          (fail)
           (fmt fmt)
           (logging)
           (list-utils)
@@ -19,11 +20,6 @@
   ;;; we need for testing.  So we use system, and redirect stderr and stdout to
   ;;; temporary files, and subsequently read them in.  Messy, but fine for tests.
 
-  (define (fail msg)
-    (raise (condition
-             (make-error)
-             (make-message-condition msg))))
-
   (define (build-command-line cmd-and-args)
     (apply fmt #f (map dsp (intersperse " " cmd-and-args))))