guile-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[PATCH 21/25] new module: (ice-9 xattr)


From: KAction
Subject: [PATCH 21/25] new module: (ice-9 xattr)
Date: Mon, 18 Jul 2016 18:17:44 +0300

From: Dmitry Bogatov <address@hidden>

This module provides interface to extended filesystem attributes and
serves as example of (system foreign declarative) usage.
---
 module/Makefile.am     |  1 +
 module/ice-9/xattr.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 77 insertions(+)
 create mode 100644 module/ice-9/xattr.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index 137530d..ab30b1b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -117,6 +117,7 @@ SOURCES =                                   \
   ice-9/top-repl.scm                           \
   ice-9/unicode.scm                            \
   ice-9/vlist.scm                              \
+  ice-9/xattr.scm                              \
   ice-9/weak-vector.scm                                \
                                                \
   language/brainfuck/parse.scm                 \
diff --git a/module/ice-9/xattr.scm b/module/ice-9/xattr.scm
new file mode 100644
index 0000000..2c81e91
--- /dev/null
+++ b/module/ice-9/xattr.scm
@@ -0,0 +1,76 @@
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+(define-module (ice-9 xattr)
+  #:use-module (system foreign declarative)
+  #:use-module (rnrs bytevectors)
+  #:use-module (system foreign)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 receive)
+  #:export (xattr-set))
+
+(define *libattr* (dynamic-link "libattr"))
+
+(define-foreign-bitmask xattr-flags:
+  ((dontfollow #x001)
+   (root       #x002)
+   (trust      #x004)
+   (secure     #x008)
+   (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*)
+
+;; Converts string or bytevector into pair (pointer . length)
+(define (encode-value value)
+  (cond
+   ((bytevector? value)
+    (values (bytevector->pointer value) (bytevector-length value)))
+   ((string? value)
+    (encode-value (string->bytevector value "utf8")))
+   ((string? value)
+    (throw 'wrong-type-argument))))
+
+(define-foreign-function c-scm-syserror
+  ((string: subr))
+  :: void:)
+
+(define* (xattr-set file attrname attrvalue #:optional (flags '()))
+  (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))))
+  (unless (zero? ret)
+    (c-scm-syserror "xattr-set")))
-- 
I may be not subscribed. Please, keep me in carbon copy.




reply via email to

[Prev in Thread] Current Thread [Next in Thread]