utils.scm (3616B)
1 ;;; Utility functions for Grug. 2 3 (define-module (grug utils) 4 #:use-module (ice-9 eval-string) 5 #:use-module (ice-9 ftw) 6 #:use-module (ice-9 rdelim) 7 #:use-module (ice-9 match) 8 #:use-module (ice-9 textual-ports) 9 #:export (strip-extension 10 ls-recursive 11 delete-file-recursively 12 mkdir-p 13 load-string-with-metadata 14 write-string-to-path)) 15 16 ;; Essentially basename but automatically removes any extension 17 (define (strip-extension filename) 18 (let* ((a (basename filename)) 19 (b (string-index a #\.))) 20 (substring a 0 b))) 21 22 ;; Return a list of file paths by recursively searching a given directory. 23 ;; This is basically like running `ls -aR`. 24 (define (ls-recursive directory) 25 (let ((enter? (lambda (path stat result) #t)) 26 (leaf (lambda (path stat result) (cons path result))) 27 (err (lambda (path stat errno result) (error "Failed to list file" errno path))) 28 (noop (lambda (path stat result) result))) 29 (file-system-fold enter? leaf noop noop noop err '() directory))) 30 31 ;; Written by Ludovic Courtès for GNU Guix. 32 (define* (delete-file-recursively dir 33 #:key follow-mounts?) 34 "Delete DIR recursively, like `rm -rf', without following symlinks. Don't 35 follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore 36 errors." 37 (let ((dev (stat:dev (lstat dir)))) 38 (file-system-fold (lambda (dir stat result) ; enter? 39 (or follow-mounts? 40 (= dev (stat:dev stat)))) 41 (lambda (file stat result) ; leaf 42 (delete-file file)) 43 (const #t) ; down 44 (lambda (dir stat result) ; up 45 (rmdir dir)) 46 (const #t) ; skip 47 (lambda (file stat errno result) 48 (format (current-error-port) 49 "warning: failed to delete ~a: ~a~%" 50 file (strerror errno))) 51 #t 52 dir 53 54 ;; Don't follow symlinks. 55 lstat))) 56 57 ;; Written by Ludovic Courtès for GNU Guix. 58 (define (mkdir-p dir) 59 "Create directory DIR and all its ancestors." 60 (define absolute? 61 (string-prefix? "/" dir)) 62 63 (define not-slash 64 (char-set-complement (char-set #\/))) 65 66 (let loop ((components (string-tokenize dir not-slash)) 67 (root (if absolute? 68 "" 69 "."))) 70 (match components 71 ((head tail ...) 72 (let ((path (string-append root "/" head))) 73 (catch 'system-error 74 (lambda () 75 (mkdir path) 76 (loop tail path)) 77 (lambda args 78 (if (= EEXIST (system-error-errno args)) 79 (loop tail path) 80 (apply throw args)))))) 81 (() #t)))) 82 83 ;; Load a file, parse metadata from the top of the file and return the rest as a string. 84 ;; Using eval-string might be overkill. Perhaps a custom parser should be written? 85 ;; TODO: Allow for multi-line metadata 86 (define (load-string-with-metadata path) 87 (call-with-input-file 88 path 89 (lambda (port) 90 (values (eval-string (read-line port)) 91 (get-string-all port))))) 92 93 ;; Write a string to the file at the given path. 94 (define (write-string-to-path string path) 95 (call-with-output-file path 96 (lambda (port) 97 (display string port))))