builtins: test: Enhance with file tests.
* gash/guix-build-utils.scm (directory-exists?, executable-file?, symbolic-link?): Import from Guix. * gash/builtins.scm (test-command): Use them to enhance with file test.
This commit is contained in:
parent
863b3b5908
commit
0cab9321b2
|
@ -240,28 +240,68 @@ Options:
|
||||||
(() #f)
|
(() #f)
|
||||||
(args
|
(args
|
||||||
(let* ((option-spec
|
(let* ((option-spec
|
||||||
'((help)
|
'((is-directory (single-char #\d))
|
||||||
|
(exists (single-char #\e))
|
||||||
|
(has-size (single-char #\s))
|
||||||
|
(help)
|
||||||
|
(is-directory (single-char #\d))
|
||||||
|
(is-file (single-char #\f))
|
||||||
|
(is-symbolic-link (single-char #\L))
|
||||||
|
(is-symbolic-link (single-char #\h))
|
||||||
|
(is-readable (single-char #\r))
|
||||||
|
(is-writable (single-char #\w))
|
||||||
|
(is-exeutable (single-char #\x))
|
||||||
(version)))
|
(version)))
|
||||||
(options (getopt-long (cons "ls" args) option-spec))
|
(options (getopt-long (cons "ls" args) option-spec))
|
||||||
(help? (option-ref options 'help #f))
|
(help? (option-ref options 'help #f))
|
||||||
(version? (option-ref options 'version #f))
|
(version? (option-ref options 'version #f))
|
||||||
(files (option-ref options '() '())))
|
(files (option-ref options '() '()))
|
||||||
|
(file (and (pair? files) (car files))))
|
||||||
(cond (help? (display "Usage: test [EXPRESSION]
|
(cond (help? (display "Usage: test [EXPRESSION]
|
||||||
|
|
||||||
Options:
|
Options:
|
||||||
|
-d FILE FILE exists and is a directory
|
||||||
|
-e FILE FILE exists
|
||||||
|
-f FILE FILE exists and is a regular file
|
||||||
|
-h FILE FILE exists and is a symbolic link (same as -L)
|
||||||
|
-L FILE FILE exists and is a symbolic link (same as -h)
|
||||||
|
-r FILE FILE exists and read permission is granted
|
||||||
|
-s FILE FILE exists and has a size greater than zero
|
||||||
|
-w FILE FILE exists and write permission is granted
|
||||||
|
-x FILE FILE exists and execute (or search) permission is granted
|
||||||
--help display this help and exit
|
--help display this help and exit
|
||||||
--version display version information and exit
|
--version display version information and exit
|
||||||
"))
|
"))
|
||||||
(version? (format #t "test (GASH) ~a\n" %version))
|
(version? (format #t "test (GASH) ~a\n" %version))
|
||||||
((null? files) #f)
|
((null? files) #f)
|
||||||
(else
|
((and (= (length files) 3)
|
||||||
|
(member (cadr files) '("=" "==")))
|
||||||
(match files
|
(match files
|
||||||
((or (left "=" right)
|
((or (left "=" right)
|
||||||
(left "==" right))
|
(left "==" right))
|
||||||
(equal? left right))
|
(equal? left right))
|
||||||
(expression
|
(expression
|
||||||
(let ((status (sh-exec `(pipeline (command ',expression)))))
|
(let ((status (sh-exec `(pipeline (command ',expression)))))
|
||||||
(zero? status))))))))))
|
(zero? status)))))
|
||||||
|
((not (= (length files) 1))
|
||||||
|
(format (current-error-port) "test: too many files: ~a\n" files)
|
||||||
|
1)
|
||||||
|
((option-ref options 'is-directory #f)
|
||||||
|
(directory-exists? file))
|
||||||
|
((option-ref options 'exists #f)
|
||||||
|
(file-exists? file))
|
||||||
|
((option-ref options 'is-symbolic-link #f)
|
||||||
|
(symbolic-link? file))
|
||||||
|
((option-ref options 'is-readable #f)
|
||||||
|
(access? file R_OK))
|
||||||
|
((option-ref options 'has-size #f)
|
||||||
|
(and (file-exists? file)
|
||||||
|
(not (zero? (stat:size (stat file))))))
|
||||||
|
((option-ref options 'is-writable #f)
|
||||||
|
(access? file W_OK))
|
||||||
|
((option-ref options 'is-exeutable #f)
|
||||||
|
(access? file X_OK))
|
||||||
|
(else #f))))))
|
||||||
|
|
||||||
(define (PATH-search-path program)
|
(define (PATH-search-path program)
|
||||||
(search-path (string-split (getenv "PATH") #\:) program))
|
(search-path (string-split (getenv "PATH") #\:) program))
|
||||||
|
|
|
@ -39,6 +39,10 @@
|
||||||
dump-port
|
dump-port
|
||||||
file-name-predicate
|
file-name-predicate
|
||||||
find-files
|
find-files
|
||||||
|
|
||||||
|
directory-exists?
|
||||||
|
executable-file?
|
||||||
|
symbolic-link?
|
||||||
))
|
))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
|
@ -49,6 +53,22 @@
|
||||||
;;; Directories.
|
;;; Directories.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
(define (directory-exists? dir)
|
||||||
|
"Return #t if DIR exists and is a directory."
|
||||||
|
(let ((s (stat dir #f)))
|
||||||
|
(and s
|
||||||
|
(eq? 'directory (stat:type s)))))
|
||||||
|
|
||||||
|
(define (executable-file? file)
|
||||||
|
"Return #t if FILE exists and is executable."
|
||||||
|
(let ((s (stat file #f)))
|
||||||
|
(and s
|
||||||
|
(not (zero? (logand (stat:mode s) #o100))))))
|
||||||
|
|
||||||
|
(define (symbolic-link? file)
|
||||||
|
"Return #t if FILE is a symbolic link (aka. \"symlink\".)"
|
||||||
|
(eq? (stat:type (lstat file)) 'symlink))
|
||||||
|
|
||||||
(define (file-name-predicate regexp)
|
(define (file-name-predicate regexp)
|
||||||
"Return a predicate that returns true when passed a file name whose base
|
"Return a predicate that returns true when passed a file name whose base
|
||||||
name matches REGEXP."
|
name matches REGEXP."
|
||||||
|
|
Loading…
Reference in New Issue