[PATCH 24/25] Refactor defining foreign libattr function

[KAction]

From: Dmitry Bogatov <address@hidden>

  * module/ice-9/xattr.scm: new internal macro
    `define-libattr-functions', that generalize following properties
    of functions in libattr:
      - every function have form attr_ACTION or attr_ACTIONf, which
        have same signatures, except first argument, which is either
        'const char *filepath' or 'int fd'.
      - they all return int.

    Macro itself is rather involved, but saves from copy-and-paste
    programming.
---
 module/ice-9/xattr.scm | 79 ++++++++++++++++++++++++--------------------------
 1 file changed, 38 insertions(+), 41 deletions(-)

diff --git a/module/ice-9/xattr.scm b/module/ice-9/xattr.scm
index 804d374..5374901 100644
--- a/module/ice-9/xattr.scm
+++ b/module/ice-9/xattr.scm
@@ -33,24 +33,40 @@
    (create     #x010)
    (replace    #x020)))
 
-(export c-attr-set)
-(define-foreign-function c-attr-set
-  ((string:      path)
-   (string:      attrname)
-   (*:           attrvalue)
-   (int:         valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
-(export c-attr-setf)
-(define-foreign-function c-attr-setf
-  ((int:         fd)
-   (string:      attrname)
-   (*:           attrvalue)
-   (int:         valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
+;; Every function from libattr exist in two version -- version, that accept 
file
+;; as 'const char *', like 'attr_get' and one, that accept file as file
+;; descriptor, like 'attr_setf'. In both cases, file argument is always
+;; the first one.
+;;
+;; This macro, given function action ('set, 'get, 'remove, 'list) and
+;; arguments after first specification, defines foreign functions
+;; c-attr-ACTION, c-attr-ACTIONf and generic libattr-ACTION, that
+;; dispatches based on first argument type.
+
+(define-syntax define-libattr-functions
+  (lambda (x)
+    (syntax-case x ()
+      ((_ action (type name) ...)
+       (let ()
+         (define (format-symbol fmt)
+           (datum->syntax x (string->symbol (format #f fmt (syntax->datum 
#'action)))))
+         (with-syntax ((c-path-function-name (format-symbol "c-attr-~a"))
+                       (c-fd-function-name (format-symbol "c-attr-~af"))
+                       (generic-procedure-name (format-symbol "libattr-~a")))
+           #'(begin
+               (define-foreign-function c-path-function-name
+                 ((string: path) (type name) ...)
+                 :: int: #:dynamic-library *libattr*)
+               (define-foreign-function c-fd-function-name
+                 ((int: fd) (type name) ...)
+                 :: int: #:dynamic-library *libattr*)
+               (define (generic-procedure-name file name ...)
+                 (if (port? file)
+                     (c-fd-function-name (port->fdes file) name ...)
+                     (c-path-function-name file name ...))))))))))
+
+(define-libattr-functions set
+  (string: attrname) (*: attrvalue) (int: valuelength) (xattr-flags: flags))
 
 ;; Converts string or bytevector into pair (pointer . length)
 (define (encode-value value)
@@ -70,37 +86,18 @@
   (define ret
     (receive (pointer length)
         (encode-value attrvalue)
-      (if (port? file)
-          (c-attr-setf (port->fdes file) attrname pointer length flags)
-          (c-attr-set file attrname pointer length flags))))
+      (libattr-set file attrname pointer length flags)))
   (unless (zero? ret)
     (c-scm-syserror "xattr-set")))
 
-(define-foreign-function c-attr-get
-  ((string:      path)
-   (string:      attrname)
-   (*:           attrvalue)
-   (*:           valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
-
-(define-foreign-function c-attr-getf
-  ((int:         fd)
-   (string:      attrname)
-   (*:           attrvalue)
-   (*:           valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
+(define-libattr-functions get
+  (string: attrname) (*: attrvalue) (*: valuelength) (xattr-flags: flags))
 
 (define* (xattr-get file attrname #:optional (flags '()) #:key (decode? #t))
   (define max-valuelen (* 64 1024))
   (with-pointer ((int: valuelength = max-valuelen)
                  (attrvalue *--> max-valuelen))
-      (%ret = (if (port? file)
-                  (c-attr-getf (port->fdes file) attrname attrvalue 
valuelength flags)
-                  (c-attr-get file attrname attrvalue valuelength flags)))
+      (%ret = (libattr-get file attrname attrvalue valuelength flags))
     ;; No matter how long actual value is, attrvalue is bytevector
     ;; with length of `max-valuelen'. We need only first `valuelength'
     ;; from it. It is unexpectedly complicated to splice bytevectory.
-- 
I may be not subscribed. Please, keep me in carbon copy.