np/hdl-unit-test-suite
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Print understandable error message when file/dir not found

Browse Source
This commit is contained in:
Nikolay Puzanov 2022-07-08 22:05:22 +03:00
parent 8b4ae738a1
commit 72c2f9445b
1 changed files with 115 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

161
utest.scm
View File

@ -177,6 +177,42 @@
(println (convert-log-item str colorize))))) (println (convert-log-item str colorize)))))
log-strings)) log-strings))
;;;
;;; Catch exception and continue with default value
;;;
(define-syntax guard
(syntax-rules ()
((_ default code...)
(with-exception-handler (lambda (e) default)
(lambda () code...)
#:unwind? #t))))
;;;
;;; Check path existence
;;; If path not exists throw exception
;;;
(define (check-path path)
(if (not (file-exists? path))
(raise-exception (format "Path ~a is not exists" path))
(let ((type (stat:type (stat path))))
(if (or (not (access? path R_OK))
(and (eq? type 'directory)
(not (access? path X_OK))))
(raise-exception (format "Path ~a is not readable" path))
#t))))
;;;
;;; Convert path to absolute path
;;;
(define* (path->absolute path #:optional (base ""))
(let ((path
(if (or (string-null? base)
(absolute-file-name? path))
path
(string-append base "/" path))))
(check-path path)
(canonicalize-path path)))
;;; ;;;
;;; Create file with simulation timeout watchdog ;;; Create file with simulation timeout watchdog
;;; ;;;
@ -202,7 +238,7 @@
(* " $finish;") (* " $finish;")
(* " end") (* " end")
(* "endmodule"))) (* "endmodule")))
(canonicalize-path filename))) (path->absolute filename)))
;;; ;;;
;;; Create dump module ;;; Create dump module
@ -221,29 +257,31 @@
(* " $dumpvars(0, ~a);" top) (* " $dumpvars(0, ~a);" top)
(* " end") (* " end")
(* "endmodule"))) (* "endmodule")))
(canonicalize-path filename))) (path->absolute filename)))
;;; ;;;
;;; Return directory list ;;; Return directory list
;;; ;;;
(define (list-dir path) (define (list-dir path)
(let ((dir (opendir path))) (if (file-exists? path)
(let loop ((ls '())) (let ((dir (opendir path)))
(let ((item (readdir dir))) (let loop ((ls '()))
(if (eof-object? item) (let ((item (readdir dir)))
(begin (if (eof-object? item)
(closedir dir) (begin
ls) (closedir dir)
(if (or (string=? item ".") ls)
(string=? item "..")) (if (or (string=? item ".")
(loop ls) (string=? item ".."))
(loop (cons (string-append path "/" item) ls)))))))) (loop ls)
(loop (cons (string-append path "/" item) ls)))))))
'()))
;;; ;;;
;;; Recursive delete directory ;;; Recursive delete directory
;;; ;;;
(define (delete-recursive path) (define (delete-recursive path)
(let ((path (canonicalize-path path))) (let ((path (path->absolute path)))
(if (eq? 'directory (stat:type (stat path))) (if (eq? 'directory (stat:type (stat path)))
(begin (begin
(for-each delete-recursive (list-dir path)) (for-each delete-recursive (list-dir path))
@ -251,42 +289,48 @@
(delete-file path)))) (delete-file path))))
;;; ;;;
;;; Convert path to absolute path ;;; Recursive find path items for which the function f returns true
;;;
(define* (path->absolute path #:optional (base ""))
(canonicalize-path
(if (string-null? base)
path
(string-append base "/" path))))
;;;
;;; Find path items for which the function f returns true
;;; (fn fullpath type) : (-> (string symbol) boolean) ;;; (fn fullpath type) : (-> (string symbol) boolean)
;;; Returns empty list if files not found ;;; Returns empty list if files not found
;;; ;;;
(define* (find-paths fn base #:optional (follow-symlink #f)) (define* (find-paths-rec fn base #:optional (follow-symlink #f))
(let ((ls (list-dir base))) (let ((ls (list-dir base)))
(let ((files.dirs (let ((files.dirs
(fold (lambda (name f.d) (fold (lambda (name f.d)
(let ((files (car f.d)) ;; There is a risk that some paths may have disappeared during recursive search.
(dirs (cdr f.d))) ;; To avoid an error, we can catch the exception from the stat function
(let* ((t (stat:type (stat name)))
(f (if (fn name t) (cons name files) files))) ;; (let ((t (guard #f (stat:type (stat name)))))
(if (or (eq? t 'directory) ;; (if t
(and follow-symlink ;; (let* ((files (car f.d))
(eq? t symlink))) ;; (dirs (cdr f.d))
(cons f (cons name dirs)) ;; (f (if (fn name t) (cons name files) files)))
(cons f dirs))))) ;; (if (or (eq? t 'directory)
;; (and follow-symlink
;; (eq? t symlink)))
;; (cons f (cons name dirs))
;; (cons f dirs)))
;; f.d))
(let* ((files (car f.d))
(dirs (cdr f.d))
(t (stat:type (stat name)))
(f (if (fn name t) (cons name files) files)))
(if (or (eq? t 'directory)
(and follow-symlink
(eq? t symlink)))
(cons f (cons name dirs))
(cons f dirs))))
'(()) ls))) '(()) ls)))
(let ((files (car files.dirs)) (let ((files (car files.dirs))
(dirs (cdr files.dirs))) (dirs (cdr files.dirs)))
(fold (lambda (dir files) (fold (lambda (dir files)
(append files (find-paths fn dir follow-symlink))) (append files (find-paths-rec fn dir follow-symlink)))
files dirs))))) files dirs)))))
;;; ;;;
;;; Find files with name matched a regular expression ;;; Recursive find files with name matched a regular expression
;;; (find-files-regexp rx base [follow-symlink #f]) -> (listof path?) ;;; (find-files-rec-regexp rx base [follow-symlink #f]) -> (listof path?)
;;; rx : string? ;;; rx : string?
;;; base : string? ;;; base : string?
;;; follow-symlink : boolean? ;;; follow-symlink : boolean?
@ -294,15 +338,40 @@
;;; rx - regulat expression ;;; rx - regulat expression
;;; base - base directory for files search ;;; base - base directory for files search
;;; ;;;
(define* (find-files-regexp rx base #:optional (follow-symlink #f)) (define* (find-files-rec-regexp rx base #:optional (follow-symlink #f))
(if (eq? 'regular (stat:type (stat base))) (if (eq? 'regular (stat:type (stat base)))
(if (string-match rx (basename base)) (list base) '()) (if (string-match rx (basename base)) (list base) '())
(find-paths (find-paths-rec
(lambda (f t) (lambda (f t)
(and (eq? t 'regular) (and (eq? t 'regular)
(string-match rx (basename f)))) (string-match rx (basename f))))
base follow-symlink))) base follow-symlink)))
;;;
;;; Recursive find files in testbench base directory
;;;
(define* (utest/find-files-rec rx #:key (base "") (follow-symlink #f))
(find-files-rec-regexp
rx
(if (string-null? base)
(utest/base-path)
(format "~a/~a" (utest/base-path) base))
follow-symlink))
;;;
;;; Find files in testbench base directory
(define* (utest/find-files rx #:key (base "") (follow-symlink #f))
(let* ((base (path->absolute
(if (string-null? base)
(utest/base-path)
(format "~a/~a" (utest/base-path) base))))
(ls (list-dir base)))
(filter (lambda (f)
(and (not (string=? f "."))
(not (string=? f ".."))
(string-match rx f)))
ls)))
;;; ;;;
;;; Prepare argument list ;;; Prepare argument list
;;; #f -> '() ;;; #f -> '()
@ -539,7 +608,7 @@
(define (collect-test-procs files) (define (collect-test-procs files)
(fold (fold
(lambda (f procs) (lambda (f procs)
(let ((f (canonicalize-path f))) (let ((f (path->absolute f)))
(append (append
procs procs
(map (lambda (proc) (list proc (dirname f) (basename f))) (map (lambda (proc) (list proc (dirname f) (basename f)))
@ -556,7 +625,7 @@
(base (cadr test)) (base (cadr test))
(name (proc 'name)) (name (proc 'name))
(name (format "~a~a/~a" (name (format "~a~a/~a"
(let* ((pwd (string-append (canonicalize-path (getcwd)) "/")) (let* ((pwd (string-append (path->absolute (getcwd)) "/"))
(base-loc (base-loc
(if (string-prefix? pwd base) (if (string-prefix? pwd base)
(substring base (string-length pwd)) (substring base (string-length pwd))
@ -740,7 +809,7 @@
(define (delete-work-dirs base force) (define (delete-work-dirs base force)
(let ((work-dirs (let ((work-dirs
(if force (if force
(find-paths (find-paths-rec
(lambda (p t) (lambda (p t)
(and (eq? t 'directory) (and (eq? t 'directory)
(string-match (string-match
@ -751,14 +820,14 @@
(lambda (makefile work-dirs) (lambda (makefile work-dirs)
(append (append
work-dirs work-dirs
(find-paths (find-paths-rec
(lambda (p t) (lambda (p t)
(and (eq? t 'directory) (and (eq? t 'directory)
(string-match (string-match
(format "^~a~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX (basename makefile)) (format "^~a~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX (basename makefile))
(basename p)))) (basename p))))
(dirname makefile)))) (dirname makefile))))
'() (find-files-regexp MAKEFILE_NAME_REGEXP base))))) '() (find-files-rec-regexp MAKEFILE_NAME_REGEXP base)))))
(if (null? work-dirs) (if (null? work-dirs)
(printf "Working folders not found\n") (printf "Working folders not found\n")
(for-each (for-each
@ -841,7 +910,7 @@
(jobs (string->number (option-ref options 'jobs "0"))) (jobs (string->number (option-ref options 'jobs "0")))
(jobs (if (zero? jobs) (current-processor-count) jobs)) (jobs (if (zero? jobs) (current-processor-count) jobs))
(rest (option-ref options '() '())) (rest (option-ref options '() '()))
(path (canonicalize-path (if (null? rest) (getcwd) (car rest))))) (path (path->absolute (if (null? rest) (getcwd) (car rest)))))
(cond (cond
((option-ref options 'help #f) (print-help (car args))) ((option-ref options 'help #f) (print-help (car args)))
@ -860,7 +929,7 @@
(let ((makefiles (let ((makefiles
(if (eq? 'regular (stat:type (stat path))) (if (eq? 'regular (stat:type (stat path)))
(list path) (list path)
(find-files-regexp MAKEFILE_NAME_REGEXP path)))) (find-files-rec-regexp MAKEFILE_NAME_REGEXP path))))
(if (<= jobs 1) (if (<= jobs 1)
(execute-tests (collect-test-procs makefiles)) (execute-tests (collect-test-procs makefiles))