From: Dmitry Bogatov <kact...@gnu.org> 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.