89 lines
2.4 KiB
Scheme
89 lines
2.4 KiB
Scheme
(require 'unix)
|
|
|
|
;; Map file type to letter
|
|
|
|
(define type-char-map
|
|
'((regular . #\-) (directory . #\d) (symlink . #\l) (socket . #\=)
|
|
(fifo . #\p) (character-special . #\c) (block-special . #\b)
|
|
(unknown . #\?)))
|
|
|
|
;; Map file mode to /bin/ls-style mode string without/with taking
|
|
;; setuid/setgid bit into account
|
|
|
|
(define perm-tab '#("---" "--x" "-w-" "-wx" "r--" "r-x" "rw-" "rwx"))
|
|
(define perm-tab1 '#("--S" "--s" "-wS" "-ws" "r-S" "r-s" "rwS" "rws"))
|
|
|
|
;; Right justify string within field of `n' spaces
|
|
|
|
(define (rjust str n)
|
|
(let* ((y (string-append (make-string n #\space) str))
|
|
(l (string-length y)))
|
|
(substring y (- l n) l)))
|
|
|
|
;; Left justify string within field of `n' spaces
|
|
|
|
(define (ljust str n)
|
|
(let* ((y (string-append str (make-string n #\space)))
|
|
(l (string-length y)))
|
|
(substring y 0 n)))
|
|
|
|
|
|
(define (print-type type)
|
|
(display (cdr (assq type type-char-map))))
|
|
|
|
(define (print-perm perm setid?)
|
|
(let ((bits (vector-ref (if setid? perm-tab1 perm-tab) perm)))
|
|
(display bits)))
|
|
|
|
;; This could probably be made more efficient by using Elk's bitstring
|
|
;; extension
|
|
|
|
(define (print-mode mode)
|
|
(let ((owner 0) (group 0) (world (modulo mode 8)))
|
|
(set! mode (quotient mode 8)) (set! group (modulo mode 8))
|
|
(set! mode (quotient mode 8)) (set! owner (modulo mode 8))
|
|
(set! mode (quotient mode 8))
|
|
(print-perm owner (>= mode 4))
|
|
(print-perm group (odd? (quotient mode 2)))
|
|
(print-perm world #f)))
|
|
|
|
(define (print-nlink nlink)
|
|
(display (rjust (number->string nlink) 3))
|
|
(display #\space))
|
|
|
|
(define (print-owner uid)
|
|
(display (ljust (passwd-name (unix-get-passwd uid)) 8)))
|
|
|
|
(define (print-size size)
|
|
(display (rjust (number->string size) 9)))
|
|
|
|
(define (print-mtime mtime)
|
|
(display (substring (unix-time->string mtime) 3 16))
|
|
(display #\space))
|
|
|
|
(define (print-name name)
|
|
(display name))
|
|
|
|
(define (print-link name)
|
|
(display " -> ")
|
|
(display (unix-readlink name)))
|
|
|
|
(define (list-entry name)
|
|
(if (not (char=? (string-ref name 0) #\.))
|
|
(let ((s (unix-lstat name)))
|
|
(print-type (stat-type s))
|
|
(print-mode (stat-mode s))
|
|
(print-nlink (stat-nlink s))
|
|
(print-owner (stat-uid s))
|
|
(print-size (stat-size s))
|
|
(print-mtime (stat-mtime s))
|
|
(print-name name)
|
|
(if (eq? (stat-type s) 'symlink)
|
|
(print-link name))
|
|
(newline))))
|
|
|
|
(define (ls)
|
|
(for-each list-entry (unix-read-directory ".")))
|
|
|
|
(ls)
|