diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2019-05-06 23:27:31 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-05-06 23:27:31 +0200 |
commit | 63f6581335d3d41dae4dc52ce37d593322a6ec19 (patch) | |
tree | 10641b5fd156d80d7f5061704e9e194de84f2af3 | |
parent | Add value function. (diff) | |
download | calp-63f6581335d3d41dae4dc52ce37d593322a6ec19.tar.gz calp-63f6581335d3d41dae4dc52ce37d593322a6ec19.tar.xz |
Add glob routine.
Diffstat (limited to '')
-rw-r--r-- | module/config.scm | 18 | ||||
-rw-r--r-- | module/glob.scm | 49 |
2 files changed, 52 insertions, 15 deletions
diff --git a/module/config.scm b/module/config.scm index d62b05db..e1000641 100644 --- a/module/config.scm +++ b/module/config.scm @@ -8,22 +8,10 @@ (srfi srfi-88) (ice-9 ftw) (ice-9 regex) - (ice-9 rdelim)) + (ice-9 rdelim) + (glob)) -(define (p str) - "Pathify string." - (regexp-substitute/global - #f "~[^/]*" str - 'pre (lambda (_) (getenv "HOME")) 'post)) - -(define (filename-hidden? str) - (char=? #\. (string-ref str 0))) - -(calendar-files - (let ((path #; "/mnt/arch/home/hugo/.calendars/" - (p "~/.calendars/"))) - (map (cut string-append path <>) - (scandir path (negate filename-hidden?))))) +(calendar-files (glob "~/.calendars/*")) ;;; TODO possibly replace with propper lookup (define my-courses diff --git a/module/glob.scm b/module/glob.scm new file mode 100644 index 00000000..d4cd68a5 --- /dev/null +++ b/module/glob.scm @@ -0,0 +1,49 @@ +(define-module (glob) + :use-module (system foreign) + :use-module (rnrs bytevectors) + :export (glob)) + + +(define (glob-err epath eerrno) + (error "Glob errored on ~s with errno = ~a" + (pointer->string epath) eerrno)) + +(eval-when (expand) + (read-enable 'curly-infix)) +(define << ash) + +(define GLOB_ERR {1 << 0})#| Return on read errors. |# +(define GLOB_MARK {1 << 1})#| Append a slash to each name. |# +(define GLOB_NOSORT {1 << 2})#| Don't sort the names. |# +(define GLOB_DOOFFS {1 << 3})#| Insert PGLOB->gl_offs NULLs. |# +(define GLOB_NOCHECK {1 << 4})#| If nothing matches, return the pattern. |# +(define GLOB_APPEND {1 << 5})#| Append to results of a previous call. |# +(define GLOB_NOESCAPE {1 << 6})#| Backslashes don't quote metacharacters. |# +(define GLOB_PERIOD {1 << 7})#| Leading `.' can be matched by metachars. |# + +(define GLOB_MAGCHAR {1 << 8})#| Set in gl_flags if any metachars seen. |# +(define GLOB_ALTDIRFUNC {1 << 9})#| Use gl_opendir et al functions. |# +(define GLOB_BRACE {1 << 10})#| Expand "{a,b}" to "a" "b". |# +(define GLOB_NOMAGIC {1 << 11})#| If no magic chars, return the pattern. |# +(define GLOB_TILDE {1 << 12})#| Expand ~user and ~ to home directories. |# +(define GLOB_ONLYDIR {1 << 13})#| Match only directories. |# +(define GLOB_TILDE_CHECK {1 << 14})#| Like GLOB_TILDE but return an error + if the user name is not available. |# + +(define glob% + (let ((this (dynamic-link))) + (pointer->procedure + int (dynamic-func "glob" this) `(* ,int * *)))) + +(define (glob str) + (let ((bv (make-bytevector 100))) + (let* ((globptr (glob% (string->pointer str) + (logior GLOB_MARK GLOB_BRACE GLOB_TILDE_CHECK) + (procedure->pointer int glob-err (list '* int)) + (bytevector->pointer bv))) + (globstr (parse-c-struct (bytevector->pointer bv) (list size_t '* size_t)))) + + ;; TODO the 'u64 requires that the system has 64 bit wide pointers... + (let ((strvec (pointer->bytevector (cadr globstr) (car globstr) 0 'u64))) + (map (compose pointer->string make-pointer) + (bytevector->uint-list strvec (native-endianness) (sizeof '*))))))) |