new version
[emacs.git] / lisp / ls-lisp.el
blobdbebfb800ce29e899eb8921daad3d253efcfb530
1 ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
3 ;; Copyright (C) 1992, 1994 by Sebastian Kremer <sk@thp.uni-koeln.de>
5 ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
6 ;; Maintainer: FSF
7 ;; Keywords: unix
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
26 ;;; Commentary:
28 ;; INSTALLATION =======================================================
29 ;;
30 ;; Put this file into your load-path. To use it, load it
31 ;; with (load "ls-lisp").
33 ;; OVERVIEW ===========================================================
35 ;; This file overloads the function insert-directory to implement it
36 ;; directly from Emacs lisp, without running `ls' in a subprocess.
38 ;; It is useful if you cannot afford to fork Emacs on a real memory UNIX,
39 ;; under VMS, or if you don't have the ls program, or if you want
40 ;; different format from what ls offers.
42 ;; This function uses regexps instead of shell
43 ;; wildcards. If you enter regexps remember to double each $ sign.
44 ;; For example, to include files *.el, enter `.*\.el$$',
45 ;; resulting in the regexp `.*\.el$'.
47 ;; RESTRICTIONS =====================================================
49 ;; * many ls switches are ignored, see docstring of `insert-directory'.
51 ;; * Only numeric uid/gid
53 ;; TODO ==============================================================
55 ;; Recognize some more ls switches: R F
57 ;;; Code:
59 ;;;###autoload
60 (defvar ls-lisp-support-shell-wildcards t
61 "*Non-nil means file patterns are treated as shell wildcards.
62 nil means they are treated as Emacs regexps (for backward compatibility).
63 This variable is checked by \\[insert-directory] only when `ls-lisp.el'
64 package is used.")
66 (defun insert-directory (file &optional switches wildcard full-directory-p)
67 "Insert directory listing for FILE, formatted according to SWITCHES.
68 Leaves point after the inserted text.
69 Optional third arg WILDCARD means treat FILE as shell wildcard.
70 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
71 switches do not contain `d', so that a full listing is expected.
73 This version of the function comes from `ls-lisp.el'. It doesn not
74 run any external programs or shells. It supports ordinary shell
75 wildcards if `ls-lisp-support-shell-wildcards' variable is non-nil;
76 otherwise, it interprets wildcards as regular expressions to match
77 file names.
79 Not all `ls' switches are supported. The switches that work
80 are: A a c i r S s t u"
81 (let ((handler (find-file-name-handler file 'insert-directory)))
82 (if handler
83 (funcall handler 'insert-directory file switches
84 wildcard full-directory-p)
85 ;; Sometimes we get ".../foo*/" as FILE. While the shell and
86 ;; `ls' don't mind, we certainly do, because it makes us think
87 ;; there is no wildcard, only a directory name.
88 (if (and ls-lisp-support-shell-wildcards
89 (string-match "[[?*]" file))
90 (progn
91 (or (not (eq (aref file (1- (length file))) ?/))
92 (setq file (substring file 0 (1- (length file)))))
93 (setq wildcard t)))
94 ;; Convert SWITCHES to a list of characters.
95 (setq switches (append switches nil))
96 (if wildcard
97 (setq wildcard
98 (if ls-lisp-support-shell-wildcards
99 (wildcard-to-regexp (file-name-nondirectory file))
100 (file-name-nondirectory file))
101 file (file-name-directory file)))
102 (if (or wildcard
103 full-directory-p)
104 (let* ((dir (file-name-as-directory file))
105 (default-directory dir);; so that file-attributes works
106 (sum 0)
108 short
109 (file-list (directory-files dir nil wildcard))
110 file-alist
111 (now (current-time))
112 ;; do all bindings here for speed
113 fil attr)
114 (cond ((memq ?A switches)
115 (setq file-list
116 (ls-lisp-delete-matching "^\\.\\.?$" file-list)))
117 ((not (memq ?a switches))
118 ;; if neither -A nor -a, flush . files
119 (setq file-list
120 (ls-lisp-delete-matching "^\\." file-list))))
121 (setq file-alist
122 (mapcar
123 (function
124 (lambda (x)
125 ;; file-attributes("~bogus") bombs
126 (cons x (file-attributes (expand-file-name x)))))
127 ;; inserting the call to directory-files right here
128 ;; seems to stimulate an Emacs bug
129 ;; ILLEGAL DATATYPE (#o37777777727) or #o67
130 file-list))
131 ;; ``Total'' line (filled in afterwards).
132 (insert (if (car-safe file-alist)
133 "total \007\n"
134 ;; Shell says ``No match'' if no files match
135 ;; the wildcard; let's say something similar.
136 "(No match)\ntotal \007\n"))
137 (setq file-alist
138 (ls-lisp-handle-switches file-alist switches))
139 (while file-alist
140 (setq elt (car file-alist)
141 file-alist (cdr file-alist)
142 short (car elt)
143 attr (cdr elt))
144 (and attr
145 (setq sum (+ sum (nth 7 attr)))
146 (insert (ls-lisp-format short attr switches now))))
147 ;; Fill in total size of all files:
148 (save-excursion
149 (search-backward "total \007")
150 (goto-char (match-end 0))
151 (delete-char -1)
152 (insert (format "%d" (if (zerop sum) 0 (1+ (/ sum 1024)))))))
153 ;; if not full-directory-p, FILE *must not* end in /, as
154 ;; file-attributes will not recognize a symlink to a directory
155 ;; must make it a relative filename as ls does:
156 (setq file (file-name-nondirectory file))
157 (insert (ls-lisp-format file (file-attributes file) switches
158 (current-time)))))))
160 (defun ls-lisp-delete-matching (regexp list)
161 ;; Delete all elements matching REGEXP from LIST, return new list.
162 ;; Should perhaps use setcdr for efficiency.
163 (let (result)
164 (while list
165 (or (string-match regexp (car list))
166 (setq result (cons (car list) result)))
167 (setq list (cdr list)))
168 result))
170 (defun ls-lisp-handle-switches (file-alist switches)
171 ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
172 ;; Return new alist sorted according to SWITCHES which is a list of
173 ;; characters. Default sorting is alphabetically.
174 (let (index)
175 (setq file-alist
176 (sort file-alist
177 (cond ((memq ?S switches) ; sorted on size
178 (function
179 (lambda (x y)
180 ;; 7th file attribute is file size
181 ;; Make largest file come first
182 (< (nth 7 (cdr y))
183 (nth 7 (cdr x))))))
184 ((memq ?t switches) ; sorted on time
185 (setq index (ls-lisp-time-index switches))
186 (function
187 (lambda (x y)
188 (ls-lisp-time-lessp (nth index (cdr y))
189 (nth index (cdr x))))))
190 (t ; sorted alphabetically
191 (function
192 (lambda (x y)
193 (string-lessp (car x)
194 (car y)))))))))
195 (if (memq ?r switches) ; reverse sort order
196 (setq file-alist (nreverse file-alist)))
197 file-alist)
199 ;; From Roland McGrath. Can use this to sort on time.
200 (defun ls-lisp-time-lessp (time0 time1)
201 (let ((hi0 (car time0))
202 (hi1 (car time1))
203 (lo0 (car (cdr time0)))
204 (lo1 (car (cdr time1))))
205 (or (< hi0 hi1)
206 (and (= hi0 hi1)
207 (< lo0 lo1)))))
210 (defun ls-lisp-format (file-name file-attr switches now)
211 (let ((file-type (nth 0 file-attr)))
212 (concat (if (memq ?i switches) ; inode number
213 (format "%6d " (nth 10 file-attr)))
214 ;; nil is treated like "" in concat
215 (if (memq ?s switches) ; size in K
216 (format "%4d " (1+ (/ (nth 7 file-attr) 1024))))
217 (nth 8 file-attr) ; permission bits
218 ;; numeric uid/gid are more confusing than helpful
219 ;; Emacs should be able to make strings of them.
220 ;; user-login-name and user-full-name could take an
221 ;; optional arg.
222 (format " %3d %-8s %-8s %8d "
223 (nth 1 file-attr) ; no. of links
224 (if (= (user-uid) (nth 2 file-attr))
225 (user-login-name)
226 (int-to-string (nth 2 file-attr))) ; uid
227 (if (eq system-type 'ms-dos)
228 "root" ; everything is root on MSDOS.
229 (int-to-string (nth 3 file-attr))) ; gid
230 (nth 7 file-attr) ; size in bytes
232 (ls-lisp-format-time file-attr switches now)
234 file-name
235 (if (stringp file-type) ; is a symbolic link
236 (concat " -> " file-type)
238 "\n"
241 (defun ls-lisp-time-index (switches)
242 ;; Return index into file-attributes according to ls SWITCHES.
243 (cond
244 ((memq ?c switches) 6) ; last mode change
245 ((memq ?u switches) 4) ; last access
246 ;; default is last modtime
247 (t 5)))
249 (defun ls-lisp-format-time (file-attr switches now)
250 ;; Format time string for file with attributes FILE-ATTR according
251 ;; to SWITCHES (a list of ls option letters of which c and u are recognized).
252 ;; Use the same method as `ls' to decide whether to show time-of-day or year,
253 ;; depending on distance between file date and NOW.
254 (let* ((time (nth (ls-lisp-time-index switches) file-attr))
255 (diff16 (- (car time) (car now)))
256 (diff (+ (ash diff16 16) (- (car (cdr time)) (car (cdr now)))))
257 (past-cutoff (- (* 6 30 24 60 60))) ; 6 30-day months
258 (future-cutoff (* 60 60))) ; 1 hour
259 (format-time-string
260 (if (and
261 (<= past-cutoff diff) (<= diff future-cutoff)
262 ;; Sanity check in case `diff' computation overflowed.
263 (<= (1- (ash past-cutoff -16)) diff16)
264 (<= diff16 (1+ (ash future-cutoff -16))))
265 "%b %e %H:%M"
266 "%b %e %Y")
267 time)))
269 (provide 'ls-lisp)
271 ;;; ls-lisp.el ends here