Mercurial > emacs
comparison lisp/ls-lisp.el @ 416:954d6271f0e9
(dired-lisp-ls): handles A a S r i s switches now.
(dired-lisp-delete-matching): new
(dired-lisp-handle-switches): new
author | Sebastian Kremer <sk@thp.uni-koeln.de> |
---|---|
date | Thu, 26 Sep 1991 16:03:09 +0000 |
parents | 7811acc9c926 |
children | 51793184f9a9 |
comparison
equal
deleted
inserted
replaced
415:ba116e58de49 | 416:954d6271f0e9 |
---|---|
1 ;;;; dired-lisp.el - emulate ls completely in Emacs Lisp. $Revision: 1.2 $ | 1 ;;;; dired-lisp.el - emulate ls completely in Emacs Lisp. $Revision: 1.3 $ |
2 ;;;; Copyright (C) 1991 Sebastian Kremer <sk@thp.uni-koeln.de> | 2 ;;;; Copyright (C) 1991 Sebastian Kremer <sk@thp.uni-koeln.de> |
3 | 3 |
4 ;;;; READ THE WARNING BELOW BEFORE USING THIS PROGRAM! | 4 ;;;; READ THE WARNING BELOW BEFORE USING THIS PROGRAM! |
5 | 5 |
6 ;;;; Useful if you cannot afford to fork Emacs on a real memory UNIX, | 6 ;;;; Useful if you cannot afford to fork Emacs on a real memory UNIX, |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to | 22 ;; along with GNU Emacs; see the file COPYING. If not, write to |
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | 23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
24 | 24 |
25 ;;;; WARNING: | 25 ;;;; WARNING: |
26 | 26 |
27 ;;;; Sometimes I get an internal Emacs error: | 27 ;;;; With earlier version of this program I sometimes got an internal |
28 ;;;; Emacs error: | |
28 | 29 |
29 ;;;; Signalling: (wrong-type-argument natnump #<EMACS BUG: ILLEGAL | 30 ;;;; Signalling: (wrong-type-argument natnump #<EMACS BUG: ILLEGAL |
30 ;;;; DATATYPE (#o37777777727) Save your buffers immediately and please | 31 ;;;; DATATYPE (#o37777777727) Save your buffers immediately and please |
31 ;;;; report this bug>) | 32 ;;;; report this bug>) |
32 | 33 |
33 ;;;; Sometimes emacs just crashes with a fatal error. | 34 ;;;; The datatype differs (I also got #o67 once). |
35 | |
36 ;;;; Sometimes emacs just crashed with a fatal error. | |
37 | |
38 ;;;; After I've avoided using directory-files and file-attributes | |
39 ;;;; together inside a mapcar, the bug didn't surface any longer. | |
34 | 40 |
35 ;;; RESTRICTIONS: | 41 ;;; RESTRICTIONS: |
36 ;;;; Always sorts by name (ls switches are completely ignored for now) | 42 ;;;; ls switches are mostly ignored |
37 ;;;; Cannot display date of file, displays a fake date "Jan 00 00:00" instead | 43 ;;;; Cannot display date of file, displays a fake date "Jan 00 00:00" instead |
38 ;;;; Only numeric uid/gid | 44 ;;;; Only numeric uid/gid |
39 ;;;; Loading ange-ftp breaks it | 45 ;;;; Loading ange-ftp breaks it |
40 | 46 |
41 ;;;; It is surprisingly fast, though! | 47 ;;;; It is surprisingly fast, though! |
42 | 48 |
43 ;;;; TODO: | 49 ;;;; TODO: |
44 ;;;; Recognize at least some ls switches: l R g F i | 50 ;;;; Recognize at some more ls switches: R F |
45 | 51 |
46 (require 'dired) ; we will redefine this function: | 52 (require 'dired) ; we will redefine dired-ls: |
47 | 53 (or (fboundp 'dired-lisp-unix-ls) |
48 (defun dired-ls (file &optional switches wildcard full-directory-p) | 54 (fset 'dired-lisp-unix-ls (symbol-function 'dired-ls))) |
49 "dired-lisp.el's version of dired-ls." | 55 |
50 ; "Insert ls output of FILE, optionally formatted with SWITCHES. | 56 (fset 'dired-ls 'dired-lisp-ls) |
51 ;Optional third arg WILDCARD means treat FILE as shell wildcard. | 57 |
52 ;Optional fourth arg FULL-DIRECTORY-P means file is a directory and | 58 (defun dired-lisp-ls (file &optional switches wildcard full-directory-p) |
53 ;switches do not contain `d'. | 59 "dired-lisp.el's version of dired-ls. |
54 ; | 60 Known switches: A a S r i s |
55 ;SWITCHES default to dired-listing-switches." | 61 Others are ignored. |
62 | |
63 Insert ls output of FILE, optionally formatted with SWITCHES. | |
64 Optional third arg WILDCARD means treat non-directory part of FILE | |
65 as emacs regexp (_not_ a shell wildcard). | |
66 | |
67 Optional fourth arg FULL-DIRECTORY-P means file is a directory and | |
68 switches do not contain `d'. | |
69 | |
70 SWITCHES default to dired-listing-switches." | |
56 (or switches (setq switches dired-listing-switches)) | 71 (or switches (setq switches dired-listing-switches)) |
72 (or (consp switches) ; convert to list of chars | |
73 (setq switches (mapcar 'identity switches))) | |
57 (if wildcard | 74 (if wildcard |
58 (error "Cannot handle wildcards in lisp emulation of `ls'.")) | 75 (setq wildcard (file-name-nondirectory file) ; actually emacs regexp |
59 (if full-directory-p | 76 ;; perhaps convert it from shell to emacs syntax? |
77 file (file-name-directory file))) | |
78 (if (or wildcard | |
79 full-directory-p) | |
60 (let* ((dir (file-name-as-directory file)) | 80 (let* ((dir (file-name-as-directory file)) |
61 (start (length dir)) | 81 (default-directory dir);; so that file-attributes works |
62 (sum 0)) | 82 (sum 0) |
63 (insert "total \007\n") ; fill in afterwards | 83 elt |
64 (insert | 84 (file-list (directory-files dir nil wildcard)) |
65 (mapconcat | 85 file-alist |
66 (function (lambda (short) | 86 ;; do all bindings here for speed |
67 (let* ((fil (concat dir short)) | 87 fil attr) |
68 (attr (file-attributes fil)) | 88 (cond ((memq ?A switches) |
69 (size (nth 7 attr))) | 89 (setq file-list |
70 ;;(debug) | 90 (dired-lisp-delete-matching "^\\.\\.?$" file-list))) |
71 (setq sum (+ sum size)) | 91 ((not (memq ?a switches)) |
72 (dired-lisp-format | 92 ;; if neither -A nor -a, flush . files |
73 ;;(file-name-nondirectory fil) | 93 (setq file-list |
74 ;;(dired-make-relative fil dir) | 94 (dired-lisp-delete-matching "^\\." file-list)))) |
75 ;;(substring fil start) | 95 (setq file-alist |
76 short | 96 (mapcar |
77 attr | 97 (function |
78 switches)))) | 98 (lambda (x) |
79 (directory-files dir) | 99 ;; file-attributes("~bogus") bombs |
80 "")) | 100 (cons x (file-attributes (expand-file-name x))))) |
101 ;; inserting the call to directory-files right here | |
102 ;; seems to stimulate an Emacs bug | |
103 ;; ILLEGAL DATATYPE (#o37777777727) or #o67 | |
104 file-list)) | |
105 (insert "total \007\n") ; filled in afterwards | |
106 (setq file-alist | |
107 (dired-lisp-handle-switches file-alist switches)) | |
108 (while file-alist | |
109 (setq elt (car file-alist) | |
110 short (car elt) | |
111 attr (cdr elt) | |
112 file-alist (cdr file-alist) | |
113 fil (concat dir short) | |
114 sum (+ sum (nth 7 attr))) | |
115 (insert (dired-lisp-format short attr switches))) | |
81 (save-excursion | 116 (save-excursion |
82 (search-backward "total \007") | 117 (search-backward "total \007") |
83 (goto-char (match-end 0)) | 118 (goto-char (match-end 0)) |
84 (delete-char -1) | 119 (delete-char -1) |
85 (insert (format "%d" sum))) | 120 (insert (format "%d" (1+ (/ sum 1024))))) |
86 ) | 121 ) |
87 ;; if not full-directory-p, FILE *must not* end in /, as | 122 ;; if not full-directory-p, FILE *must not* end in /, as |
88 ;; file-attributes will not recognize a symlink to a directory | 123 ;; file-attributes will not recognize a symlink to a directory |
89 ;; must make it a relative filename as ls does: | 124 ;; must make it a relative filename as ls does: |
90 (setq file (file-name-nondirectory file)) | 125 (setq file (file-name-nondirectory file)) |
91 (insert (dired-lisp-format file (file-attributes file) switches))) | 126 (insert (dired-lisp-format file (file-attributes file) switches)))) |
92 ) | 127 |
128 (defun dired-lisp-delete-matching (regexp list) | |
129 ;; Delete all elements matching REGEXP from LIST, return new list. | |
130 ;; Should perhaps use setcdr for efficiency | |
131 (let (result) | |
132 (while list | |
133 (or (string-match regexp (car list)) | |
134 (setq result (cons (car list) result))) | |
135 (setq list (cdr list))) | |
136 result)) | |
137 | |
138 (defun dired-lisp-handle-switches (file-alist switches) | |
139 ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES). | |
140 ;; Return new alist sorted according to switches. | |
141 (setq file-alist | |
142 (sort file-alist | |
143 (cond ((memq ?S switches) | |
144 (function | |
145 (lambda (x y) | |
146 ;; 7th file attribute is file size | |
147 ;; Make largest file come first | |
148 (< (nth 7 (cdr y)) | |
149 (nth 7 (cdr x)))))) | |
150 (t ; sorted alphabetically | |
151 (function | |
152 (lambda (x y) | |
153 (string-lessp (car x) (car y)))))))) | |
154 (if (memq ?r switches) ; reverse sort order | |
155 (setq file-alist (nreverse file-alist))) | |
156 file-alist) | |
93 | 157 |
94 (defun dired-lisp-format (file-name file-attr &optional switches) | 158 (defun dired-lisp-format (file-name file-attr &optional switches) |
95 (let ((file-type (nth 0 file-attr))) | 159 (let ((file-type (nth 0 file-attr))) |
96 (concat (nth 8 file-attr) ; permission bits | 160 (concat (if (memq ?i switches) ; inode number |
161 (concat (dired-lisp-pad (nth 10 file-attr) -6) | |
162 " ")) | |
163 (if (memq ?s switches) ; size in K | |
164 (concat (dired-lisp-pad (1+ (/ (nth 7 file-attr) 1024)) | |
165 -4) | |
166 " ")) | |
167 (nth 8 file-attr) ; permission bits | |
97 " " | 168 " " |
98 (dired-lisp-pad (nth 1 file-attr) -3) ; no. of links | 169 (dired-lisp-pad (nth 1 file-attr) -3) ; no. of links |
99 ;; numeric uid/gid are more confusing than helpful | 170 ;; numeric uid/gid are more confusing than helpful |
100 ;; Emacs should be able to make strings of them | 171 ;; Emacs should be able to make strings of them. |
172 ;; user-login-name and user-full-name could take an | |
173 ;; optional arg. | |
101 " " (dired-lisp-pad (nth 2 file-attr) -6) ; uid | 174 " " (dired-lisp-pad (nth 2 file-attr) -6) ; uid |
102 " " (dired-lisp-pad (nth 3 file-attr) -6) ; gid | 175 " " (dired-lisp-pad (nth 3 file-attr) -6) ; gid |
103 " " | 176 " " |
104 (dired-lisp-pad (nth 7 file-attr) -8) ; size in bytes | 177 (dired-lisp-pad (nth 7 file-attr) -8) ; size in bytes |
178 " " | |
105 ;; file-attributes's time is in a braindead format | 179 ;; file-attributes's time is in a braindead format |
106 ;; Emacs should have a ctime function | 180 ;; Emacs should have a ctime function |
107 " " "Jan 00 00:00 " ; fake time | 181 ;; Or current-time-string could take an optional arg. |
182 "Jan 00 00:00 " ; fake time | |
108 file-name | 183 file-name |
109 (if (stringp file-type) ; is a symbolic link | 184 (if (stringp file-type) ; is a symbolic link |
110 (concat " -> " file-type) | 185 (concat " -> " file-type) |
111 "") | 186 "") |
112 "\n" | 187 "\n" |
117 "Pad ARG to WIDTH, from left if WIDTH < 0. | 192 "Pad ARG to WIDTH, from left if WIDTH < 0. |
118 Non-nil third arg optional PAD-CHAR defaults to a space." | 193 Non-nil third arg optional PAD-CHAR defaults to a space." |
119 (or pad-char (setq pad-char ?\040)) | 194 (or pad-char (setq pad-char ?\040)) |
120 (if (integerp arg) | 195 (if (integerp arg) |
121 (setq arg (int-to-string arg))) | 196 (setq arg (int-to-string arg))) |
122 (let (l pad reverse) | 197 (let (pad reverse) |
123 (if (< width 0) | 198 (if (< width 0) |
124 (setq reverse t | 199 (setq reverse t |
125 width (- width))) | 200 width (- width))) |
126 (setq l (length arg) | 201 (setq pad (- width (length arg))) |
127 pad (- width l)) | 202 (if (> pad 0) ; ARG needs padding |
128 (if (> pad 0) | |
129 (if reverse | 203 (if reverse |
130 (concat (make-string pad pad-char) arg) | 204 (concat (make-string pad pad-char) arg) |
131 (concat arg (make-string pad pad-char))) | 205 (concat arg (make-string pad pad-char))) |
206 ;; else unpadded (perhaps longer than WIDTH) | |
132 arg))) | 207 arg))) |