[源码] LISP非递归深度遍历文件夹查找文件

admin1 · 发表于 2024-7-10 11:27:15

(defun $lie-chu-mu-lu-xia-suo-you-wen-jian$
(lst / fs-all ns wjs kzm f wj a)
;列出目录下所有文件，含子级目录，所有目录下的文件
;($lie-chu-mu-lu-xia-suo-you-wen-jian$ (list(cons "目录" "C:")(cons "扩展名" "*.dwg")))
(or (and lst
(= (type lst) 'list)
(setq kzm (cdr (assoc "扩展名" lst)))
(> (strlen kzm) 0)
(wcmatch kzm "[,`*.*,]")
)
(setq kzm "*.*")
)
(or (and lst
(= (type lst) 'list)
(setq f (cdr (assoc "目录" lst)))
)
(and lst (= (type lst) 'str) (setq f lst))
)
(and
;;; (PROGN
;;; (NOT (OR (and f (wcmatch f "[A-Z]:"))
;;; (and f (wcmatch f "[a-z]:"))
;;; )
;;; ) ;注释这里允许遍历整个磁盘
;;; )
(progn
(while (and f (wcmatch f "*`\\*"))
(setq f (vl-string-subst "/" "\" f))
)
(setq fs-all nil)
(setq fs-all (cons f fs-all))
(setq fs (vl-directory-files f "*.*" -1))
(setq fs (vl-remove ".." fs))
(setq fs (vl-remove "." fs))
(setq fs (mapcar (function (lambda (a) (strcat f "/" a))) fs))
(setq fs-all (APPEND fs-all fs))
(while (AND fs (setq f (car fs)) (< (LENGTH fs-all) 10000));文件夹超过十万就不继续遍历了
(setq ns nil)
(setq ns (vl-directory-files f "*.*" -1))
(setq ns (vl-remove ".." ns))
(setq ns (vl-remove "." ns))
(setq ns (mapcar (function (lambda (a / n)
(strcat f "/" a)
)
)
ns
)
)
(SETQ fs-all (APPEND fs-all NS))
(setq fs (append fs ns))
(setq fs (cdr fs))
)
)
)
(setq wjs nil)
(while (setq a (car fs-all))
(setq wj nil)
(setq wj (vl-directory-files a kzm 1))
(setq wj (vl-remove ".." wj))
(setq wj (vl-remove "." wj))
(setq wj (mapcar (function (lambda (b) (strcat a "/" b))) wj))
(setq wjs (cons wj wjs))
(setq fs-all (cdr fs-all))
)
(setq wjs (vl-remove nil wjs))
wjs
)

复制代码

		自动登录	找回密码
密码			立即注册