Compare commits
No commits in common. "72b5894823bcb4a6efdf5874f774d184d5aa50d5" and "6ac7a6b5353d9cd26861f0aa834f9652995e77f6" have entirely different histories.
72b5894823
...
6ac7a6b535
73
README.md
73
README.md
|
|
@ -1,73 +0,0 @@
|
|||
# xattr
|
||||
## Interface for extended filesystem attributes
|
||||
|
||||
[Extended attributes](https://en.wikipedia.org/wiki/Extended_attributes) are a special type of file attribute that lets you associate key-value pairs with a file without actually modifying the file's contents. Commonly used for program settings, tagging, and file metadata (i.e., storing a file's author with a key like “author.name”) xattrs can be used for used for pretty much anything you can dream up. They're mega-cool and useful.
|
||||
|
||||
This is a simple interface for accessing them within [Chicken Scheme](https://call-cc.org/), a friendly Scheme.
|
||||
|
||||
|
||||
## API
|
||||
### get-xattr
|
||||
`get-xattr path attr`
|
||||
|
||||
Returns the string-value of a file's extended attribute.
|
||||
If the file has no such attribute, #f is returned. In other cases (e.g., the file doesn't exist, permission not available, no filesystem support), exceptions are raised.
|
||||
|
||||
### set-xattr
|
||||
`set-xattr path attr value`
|
||||
|
||||
Sets the string-value of a file's extended attribute.
|
||||
The set value is returned, if successful.
|
||||
|
||||
### remove-xattr
|
||||
`remove-xattr path attr`
|
||||
|
||||
Removes an extended attribute from a file.
|
||||
The value of the removed attribute is returned, if successful.
|
||||
|
||||
### list-xattrs
|
||||
`list-xattrs path`
|
||||
|
||||
Returns a list of the file's extended attribute names.
|
||||
|
||||
|
||||
## Examples
|
||||
```
|
||||
(import xattr (chicken io) (chicken file))
|
||||
;; Create the test file
|
||||
(call-with-output-file "testing.txt"
|
||||
(lambda (out-port) (write-line "Just a test!" out-port)))
|
||||
|
||||
(set-xattr "testing.txt" "user.dublincore.author" "Migdal E. F. Lemmings")
|
||||
(set-xattr "testing.txt" "user.dublincore.title" "A Treatise on Almonds")
|
||||
|
||||
(get-xattr "testing.txt" "user.dublincore.author")
|
||||
;; Returns "Migdal E. F. Lemmings"
|
||||
|
||||
(list-xattrs "testing.txt")
|
||||
;; Returns '("user.dublincore.author" "user.dublincore.title")
|
||||
|
||||
(remove-xattr "testing.txt" "user.dublincore.title")
|
||||
;; Returns "A Treatise on Almonds"
|
||||
|
||||
(list-xattrs "testing.txt")
|
||||
;; Now returns '("user.dublincore.author")
|
||||
```
|
||||
|
||||
|
||||
## On GNU/Linux
|
||||
Currently, this egg only supports LiGNUx, a platform that has a particularity: The name of each attribute must contain a “namespace,” separated from the actual name by a period. For example, with the attribute named `user.xdg.origin.url`, the namespace is `user` and the name is `xdg.origin.url`. In most cases, you won't stray from the `user` namespace.
|
||||
|
||||
Don't forget to prepend “user.” to your attribute names!
|
||||
|
||||
A handy list of somewhat-standard extended attributes is hosted on FreeDesktop's website, [here](https://www.freedesktop.org/wiki/CommonExtendedAttributes/).
|
||||
|
||||
|
||||
## Requirements
|
||||
This egg requires `srfi-1` and `srfi-12`.
|
||||
|
||||
|
||||
## Meta
|
||||
**Author:** Jaidyn Ann <jadedctrl@posteo.at>
|
||||
**License:** GPLv3
|
||||
**Source:** https://github.com/jadedctrl/xattr, https://notabug.org/jadedctrl/xattr
|
||||
|
|
@ -1,7 +1,9 @@
|
|||
;; -*- Scheme -*-
|
||||
((synopsis "Access to extended attributes")
|
||||
(author "Jaidyn Ann")
|
||||
(category io)
|
||||
(category net)
|
||||
(license "GPLv3")
|
||||
(dependencies srfi-1)
|
||||
|
||||
(components (extension xattr)))
|
||||
;; (csc-options "-O3" "-d1" "-X" "bind" "-s" "-k" "-emit-link-file" "xattr.link" "-o" "xattr_ext.o"))
|
||||
;; (c-object xattr_ext)))
|
||||
|
|
|
|||
285
xattr.scm
285
xattr.scm
|
|
@ -1,5 +1,5 @@
|
|||
;;
|
||||
;; Copyright 2024, Jaidyn Levesque <jadedctrl@posteo.at>
|
||||
;; Copyright 2022, Jaidyn Levesque <jadedctrl@posteo.at>
|
||||
;;
|
||||
;; This program is free software: you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
|
|
@ -16,181 +16,176 @@
|
|||
;;
|
||||
|
||||
(module xattr
|
||||
(get-xattr set-xattr remove-xattr list-xattrs)
|
||||
(get-xattr set-xattr remove-xattr list-xattr)
|
||||
|
||||
(import scheme
|
||||
(chicken base) (chicken condition) (chicken foreign) (chicken memory)
|
||||
srfi-1)
|
||||
(import (chicken base) (chicken memory) srfi-1 scheme (chicken foreign) srfi-12)
|
||||
|
||||
(foreign-declare "#include \"xattr_ext.c\"")
|
||||
|
||||
|
||||
(foreign-declare "#include \"xattr_ext.c\"")
|
||||
;; The direct foreign binding for `get_xattr`
|
||||
(define get-xattr-foreign
|
||||
(foreign-lambda c-string* "get_xattr" c-string c-string (c-pointer int)))
|
||||
|
||||
|
||||
;; The direct foreign binding for `get_xattr`
|
||||
(define get-xattr-foreign
|
||||
(foreign-lambda c-string* "get_xattr" c-string c-string (c-pointer int)))
|
||||
;; Wrapper around get-xattr-foreign, which throws exceptions and such.
|
||||
(define (get-xattr path attr)
|
||||
(let-location ([error-code int])
|
||||
(let ([attr-value (get-xattr-foreign path attr (location error-code))]
|
||||
[exception (or (getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
attr-value))))
|
||||
|
||||
|
||||
;; Wrapper around get-xattr-foreign, which throws exceptions and such.
|
||||
(define (get-xattr path attr)
|
||||
(let-location ([error-code int])
|
||||
(let ([attr-value (get-xattr-foreign path attr (location error-code))]
|
||||
[exception (or (getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
attr-value))))
|
||||
;; The direct foreign binding for `list_xattr`
|
||||
(define list-xattr-foreign
|
||||
(foreign-lambda (c-pointer char) "list_xattr" c-string (c-pointer ssize_t) (c-pointer int)))
|
||||
|
||||
|
||||
;; The direct foreign binding for `list_xattr`
|
||||
(define list-xattrs-foreign
|
||||
(foreign-lambda (c-pointer char) "list_xattr" c-string (c-pointer ssize_t) (c-pointer int)))
|
||||
;; Wrapper around list-xattr-foreign, which throws exceptions and such.
|
||||
(define (list-xattr path)
|
||||
(let-location ([error-code int]
|
||||
[length ssize_t])
|
||||
(let ([list-pointer (list-xattr-foreign path (location length) (location error-code))]
|
||||
[exception (or (getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
;; listxattr offers a const char* \0-delimited list of strings
|
||||
(pointer->delimited-string-list list-pointer length 0)))))
|
||||
|
||||
|
||||
;; Wrapper around list-xattrs-foreign, which throws exceptions and such.
|
||||
(define (list-xattrs path)
|
||||
(let-location ([error-code int]
|
||||
[length ssize_t])
|
||||
(let ([list-pointer (list-xattrs-foreign path (location length) (location error-code))]
|
||||
[exception (or (getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
;; listxattr offers a const char* \0-delimited list of strings
|
||||
(pointer->delimited-string-list list-pointer length 0)))))
|
||||
;; The direct foreign binding for `set_xattr`
|
||||
(define set-xattr-foreign
|
||||
(foreign-lambda int "set_xattr" c-string c-string c-string (c-pointer int)))
|
||||
|
||||
|
||||
;; The direct foreign binding for `set_xattr`
|
||||
(define set-xattr-foreign
|
||||
(foreign-lambda int "set_xattr" c-string c-string c-string (c-pointer int)))
|
||||
;; Wrapper around set-xattr-foreign, throwing exceptions and all that jazz
|
||||
(define (set-xattr path attr value)
|
||||
(let-location ([error-code int])
|
||||
(let ([return-code (set-xattr-foreign path attr value (location error-code))]
|
||||
[exception (or (setxattr-exception error-code)
|
||||
(getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
value))))
|
||||
|
||||
|
||||
;; Wrapper around set-xattr-foreign, throwing exceptions and all that jazz
|
||||
(define (set-xattr path attr value)
|
||||
(let-location ([error-code int])
|
||||
(let ([return-code (set-xattr-foreign path attr value (location error-code))]
|
||||
[exception (or (setxattr-exception error-code)
|
||||
(getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
value))))
|
||||
;; The direct foreign binding for `remove_xattr`
|
||||
(define remove-xattr-foreign
|
||||
(foreign-lambda int "remove_xattr" c-string c-string))
|
||||
|
||||
|
||||
;; The direct foreign binding for `remove_xattr`
|
||||
(define remove-xattr-foreign
|
||||
(foreign-lambda int "remove_xattr" c-string c-string))
|
||||
;; Wrapper around remove-xattr-foreign, blah blah
|
||||
(define (remove-xattr path attr)
|
||||
(let* ([error-code (remove-xattr-foreign path attr)]
|
||||
[exception (or (getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
attr)))
|
||||
|
||||
|
||||
;; Wrapper around remove-xattr-foreign, blah blah
|
||||
(define (remove-xattr path attr)
|
||||
(let* ([value (get-xattr path attr)]
|
||||
[error-code (remove-xattr-foreign path attr)]
|
||||
[exception (or (getxattr-exception error-code)
|
||||
(stat-exception error-code))])
|
||||
(if exception
|
||||
(signal exception)
|
||||
value)))
|
||||
;; TODO: These exception functions should be constructed with a macro and a simple
|
||||
;; list, like `((c-constant symbol error-message) ("E2BIG" 'e2big "The attribute value was too big."))
|
||||
;; Unfortunately, it looks like chicken's macros work a good bit differently from CLs?
|
||||
;; orr I'm losing my mind
|
||||
|
||||
|
||||
;; TODO: These exception functions should be constructed with a macro and a simple
|
||||
;; list, like `((c-constant symbol error-message) ("E2BIG" 'e2big "The attribute value was too big."))
|
||||
;; Return the exception associated with an error-code as per getxattr(2), if it exists
|
||||
(define (getxattr-exception error-code)
|
||||
(cond
|
||||
[(eq? error-code (foreign-value "E2BIG" int))
|
||||
(build-exception 'e2big "The attribute value was too big.")]
|
||||
[(eq? error-code (foreign-value "ENOTSUP" int))
|
||||
(build-exception 'enotsup "Extended attributes are disabled or unavailable on this filesystem.")]
|
||||
[(eq? error-code (foreign-value "ERANGE" int))
|
||||
(build-exception 'erange "The xattr module's buffer was too small for the attribute value. Whoops <w<\"")]
|
||||
[#t
|
||||
#f]))
|
||||
|
||||
|
||||
;; Return the exception associated with an error-code as per getxattr(2), if it exists
|
||||
(define (getxattr-exception error-code)
|
||||
(cond
|
||||
[(eq? error-code (foreign-value "E2BIG" int))
|
||||
(build-exception 'e2big "The attribute value was too big.")]
|
||||
[(eq? error-code (foreign-value "ENOTSUP" int))
|
||||
(build-exception 'enotsup "Extended attributes are disabled or unavailable on this filesystem.")]
|
||||
[(eq? error-code (foreign-value "ERANGE" int))
|
||||
(build-exception 'erange "The xattr module's buffer was too small for the attribute value. Whoops <w<\"")]
|
||||
[#t
|
||||
#f]))
|
||||
;; Return the exception associated with a setxattr(2) error-code, if it exists.
|
||||
(define (setxattr-exception error-code)
|
||||
(cond
|
||||
[(eq? error-code (foreign-value "EDQUOT" int))
|
||||
(build-exception 'edquot "Setting this attribute would violate disk quota.")]
|
||||
[(eq? error-code (foreign-value "ENOSPC" int))
|
||||
(build-exception 'enospc "There is insufficient space to store the extended attribute.")]
|
||||
[(eq? error-code (foreign-value "EPERM" int))
|
||||
(build-exception 'eperm "The file is immutable or append-only.")]
|
||||
[(eq? error-code (foreign-value "ERANGE" int))
|
||||
(build-exception 'erange "Either the attribute name or value exceeds the filesystem's limit.")]
|
||||
[#t
|
||||
#f]))
|
||||
|
||||
|
||||
;; Return the exception associated with a setxattr(2) error-code, if it exists.
|
||||
(define (setxattr-exception error-code)
|
||||
(cond
|
||||
[(eq? error-code (foreign-value "EDQUOT" int))
|
||||
(build-exception 'edquot "Setting this attribute would violate disk quota.")]
|
||||
[(eq? error-code (foreign-value "ENOSPC" int))
|
||||
(build-exception 'enospc "There is insufficient space to store the extended attribute.")]
|
||||
[(eq? error-code (foreign-value "EPERM" int))
|
||||
(build-exception 'eperm "The file is immutable or append-only.")]
|
||||
[(eq? error-code (foreign-value "ERANGE" int))
|
||||
(build-exception 'erange "Either the attribute name or value exceeds the filesystem's limit.")]
|
||||
[#t
|
||||
#f]))
|
||||
;; Return the exception associated with an error-code as per stat(2), if applicable
|
||||
(define (stat-exception error-code)
|
||||
(cond
|
||||
[(eq? error-code (foreign-value "EACCES" int))
|
||||
(build-exception 'file "Search permission denied for a parent directory.")]
|
||||
[(eq? error-code (foreign-value "EBADF" int))
|
||||
(build-exception 'file "The file-descriptor is bad. Wait, wha…?")]
|
||||
[(eq? error-code (foreign-value "EFAULT" int))
|
||||
(build-exception 'file "The address is bad. OK.")]
|
||||
[(eq? error-code (foreign-value "EINVAL" int))
|
||||
(build-exception 'file "Invalid fstatat flag.")]
|
||||
[(eq? error-code (foreign-value "ELOOP" int))
|
||||
(build-exception 'file "Too many symbolic links in recursion.")]
|
||||
[(eq? error-code (foreign-value "ENAMETOOLONG" int))
|
||||
(build-exception 'file "The given pathname is too long.")]
|
||||
[(eq? error-code (foreign-value "ENOENT" int))
|
||||
(build-exception 'file "This file doesn't exist, or there is a dangling symlink.")]
|
||||
[(eq? error-code (foreign-value "ENOMEM" int))
|
||||
(build-exception 'file "Out of memory.")]
|
||||
[(eq? error-code (foreign-value "ENOTDIR" int))
|
||||
(build-exception 'file "Component of path isn't a proper directory.")]
|
||||
[(eq? error-code (foreign-value "EOVERFLOW" int))
|
||||
(build-exception 'file "An overflow has occured.")]
|
||||
[#t
|
||||
#f]))
|
||||
|
||||
|
||||
;; Return the exception associated with an error-code as per stat(2), if applicable
|
||||
(define (stat-exception error-code)
|
||||
(cond
|
||||
[(eq? error-code (foreign-value "EACCES" int))
|
||||
(build-exception 'file "Search permission denied for a parent directory.")]
|
||||
[(eq? error-code (foreign-value "EBADF" int))
|
||||
(build-exception 'file "The file-descriptor is bad. Wait, wha…?")]
|
||||
[(eq? error-code (foreign-value "EFAULT" int))
|
||||
(build-exception 'file "The address is bad. OK.")]
|
||||
[(eq? error-code (foreign-value "EINVAL" int))
|
||||
(build-exception 'file "Invalid fstatat flag.")]
|
||||
[(eq? error-code (foreign-value "ELOOP" int))
|
||||
(build-exception 'file "Too many symbolic links in recursion.")]
|
||||
[(eq? error-code (foreign-value "ENAMETOOLONG" int))
|
||||
(build-exception 'file "The given pathname is too long.")]
|
||||
[(eq? error-code (foreign-value "ENOENT" int))
|
||||
(build-exception 'file "This file doesn't exist, or there is a dangling symlink.")]
|
||||
[(eq? error-code (foreign-value "ENOMEM" int))
|
||||
(build-exception 'file "Out of memory.")]
|
||||
[(eq? error-code (foreign-value "ENOTDIR" int))
|
||||
(build-exception 'file "Component of path isn't a proper directory.")]
|
||||
[(eq? error-code (foreign-value "EOVERFLOW" int))
|
||||
(build-exception 'file "An overflow has occured.")]
|
||||
[#t
|
||||
#f]))
|
||||
;; Creates a generic exception with given symbol and message
|
||||
(define (build-exception symbol message)
|
||||
(signal (make-property-condition 'exn 'location symbol 'message message)))
|
||||
|
||||
|
||||
;; Creates a generic exception with given symbol and message
|
||||
(define (build-exception symbol message)
|
||||
(signal (make-property-condition 'exn 'location symbol 'message message)))
|
||||
;; Some C functions offer up a string-list that isn't a two-dimensional array, but a
|
||||
;; one-dimensional array with given length and strings separated by a given delimeter.
|
||||
;; This takes that sort of pointer and gives you a nice list of strings.
|
||||
(define (pointer->delimited-string-list pointer length delimiter)
|
||||
(let* ([is-zero (lambda (num) (eq? num 0))]
|
||||
[map-to-char (lambda (a) (map integer->char a))]
|
||||
[byte-list (drop-right (pointer->integers pointer length) 1)])
|
||||
(map list->string
|
||||
(map map-to-char
|
||||
(split-list is-zero byte-list)))))
|
||||
|
||||
|
||||
;; Some C functions offer up a string-list that isn't a two-dimensional array, but a
|
||||
;; one-dimensional array with given length and strings separated by a given delimeter.
|
||||
;; This takes that sort of pointer and gives you a nice list of strings.
|
||||
(define (pointer->delimited-string-list pointer length delimiter)
|
||||
(let* ([is-zero (lambda (num) (eq? num 0))]
|
||||
[map-to-char (lambda (a) (map integer->char a))]
|
||||
[pointer-ints (pointer->integers pointer length)]
|
||||
[byte-list (when (list? pointer-ints)
|
||||
(drop-right pointer-ints 1))])
|
||||
(if (and (list? byte-list)
|
||||
(not (null-list? byte-list)))
|
||||
(map list->string
|
||||
(map map-to-char
|
||||
(split-list is-zero byte-list)))
|
||||
'())))
|
||||
;; Takes a pointer and returns a list of bytes of a given length
|
||||
(define (pointer->integers pointer length)
|
||||
(let ([byte (pointer-s8-ref pointer)])
|
||||
(if (eq? length 0)
|
||||
byte
|
||||
(append (list byte)
|
||||
(pointer->integers (pointer+ pointer 1) (- length 1))))))
|
||||
|
||||
|
||||
;; Takes a pointer and returns a list of bytes of a given length
|
||||
(define (pointer->integers pointer length)
|
||||
(let ([byte (pointer-s8-ref pointer)])
|
||||
(if (eq? length 0)
|
||||
byte
|
||||
(append (list byte)
|
||||
(pointer->integers (pointer+ pointer 1) (- length 1))))))
|
||||
;; Split a list into sublists, with items passing `test` being the delimiters
|
||||
(define (split-list test list)
|
||||
(let ([before (take-while (compose not test) list)]
|
||||
[after (drop-while (compose not test) list)])
|
||||
(cond
|
||||
[(or (null-list? after) (null-list? (cdr after)))
|
||||
`(,before)]
|
||||
[(null-list? before)
|
||||
(split-list test (cdr after))]
|
||||
[#t
|
||||
(append `(,before) (split-list test (cdr after)))])))
|
||||
|
||||
|
||||
;; Split a list into sublists, with items passing `test` being the delimiters
|
||||
(define (split-list test list)
|
||||
(let ([before (take-while (compose not test) list)]
|
||||
[after (drop-while (compose not test) list)])
|
||||
(cond
|
||||
[(or (null-list? after) (null-list? (cdr after)))
|
||||
`(,before)]
|
||||
[(null-list? before)
|
||||
(split-list test (cdr after))]
|
||||
[#t
|
||||
(append `(,before) (split-list test (cdr after)))]))))
|
||||
)
|
||||
|
|
|
|||
Ŝarĝante…
Reference in New Issue