cl 的完整程式

說明： 非原創，抄來的， 放在這裡的目的是，給大家一個範例，寫一個可以釋出的lisp 程式基本就是這個格式了

http://blog.sina.com.cn/s/blog_510ac74901011fww.html

這應該還是算實用的一段程式碼，雖然，用python，perl 實現要遠遠的簡單的多。

這個程式的思想是透過系統呼叫ls -al，然後用正則解析其輸出結果，再依照這個原理遍歷每一個子目錄

;;-------------wy_file_fun.asd------------

;; 定義自己的package

(defpackage :wy.file
  (:use     :common-lisp
            :cl-ppcre)
  (:export  :walk
            :dir-detail)  )

 

 

;;--------------wy_file_fun.lisp--------------

(in-package :wy.file)

;;walk是介面函式，遍歷每一個子目錄，輸出形式是((*(filename filepath&name size flag)) size)連結串列，*代表多個，

;;以這種形式將當前目錄以及子目錄中所有的檔案和目錄都返回出來

(defun walk  (path-name) (let ((file-list nil)
                               (tmp-res nil)
                               (value-after-total 0)
                               (dir-info nil))
                           (setf dir-info (dir-detail path-name))
                           (setf file-list (elt dir-info 0))
                           (setf value-after-total (elt dir-info 1))
                           (loop for x in file-list
                                do (if (eq (elt (elt x 3) 0) #\d)
                                  (progn (setf tmp-res  (walk (elt x 1)))
                                     (setf file-list (append file-list (elt tmp-res 0)))
                                     (setf value-after-total (+ value-after-total (elt tmp-res 1)))))
                                finally (return (list file-list value-after-total)))))

 

;;dir-detail也是介面函式，當然他也被walk呼叫

;;透過正則將當前目錄ls命令的輸出轉換成((*(filename filepath&name size flag)) size)的連結串列形式，*代表多個

(defun dir-detail (path-name)
  (let ((res-ls-al (inner-os-ls-al path-name))
        (ret-table (make-hash-table))
        (res nil)
        (value-after-total nil)
        (file-list nil))
    ;strip the / at the tail of path-name
    (if  (not (string= path-name ""))
         (if (eq (elt path-name (- (length path-name) 1)) #\/)
             (if (string= path-name "/") (setf path-name "") (setf path-name (subseq path-name 0 (length path-name) 2)))))
    (loop for x in  res-ls-al
       do (multiple-value-bind
                 (tmp-string ppcre-res)
               (scan-to-strings "total\\s+(+)" x)
             (if (not (eq nil ppcre-res))
                                        ;this line is  'total XXX', convert XXX to value-after-total
                 (setf value-after-total (parse-integer (elt ppcre-res 0)))
                                        ;the below is the files
                                        ;drwxr-xr-x  4 root root 4096 Jul  9  2011 .
                                        ;drwxr-xr-x 18 root root 4096 Jul  9  2011 ..
                                        ;drwxr-xr-x  2 root ftp  4096 May 28  2011 ftp
                                        ;-rw-r--r--  1 root root    0 May  3  2011 .keep
                                        ;drwxr-xr-x 18 wyao root 4096 Feb 19 17:32 wyao
                 (multiple-value-bind
                       (tmp-string ppcre-res)
                     (scan-to-strings "(+)" x)
                   (if (not (eq nil ppcre-res))
                       (if (or (string= "." (elt ppcre-res 8)) (string= ".." (elt ppcre-res 8)))
                           nil
                           (setf file-list (cons (list
                                                  (elt ppcre-res 8)    ;name
                                                  (concatenate 'string  path-name "/" (elt ppcre-res 8) )  ;path + name
                                                  (parse-integer (elt ppcre-res 4)) ; size
                                                  (elt ppcre-res 0))  ;flag
                                                 file-list)))))
            ))
         finally (return (list file-list value-after-total))
    )))

 

;;inner-os-ls-al 是內部函式

;;用於執行/bin/ls -al這個系統呼叫，以獲得某個目錄的檔案情況

(defun inner-os-ls-al (path-name)
  (let ((p (sb-ext:process-output (sb-ext:run-program "/bin/ls" (list "-al" (eval_r(string path-name))) :output :stream)))
        (file-list nil))
    (loop for line = (read-line p nil)
       while (> (length line) 0) do (setf file-list (cons line file-list))
         finally (return file-list))))