Commit | Line | Data |
---|---|---|
76550a57 ER |
1 | ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp |
2 | ||
3f51f5a9 | 3 | ;; Copyright (C) 1992, 1994, 2000 Free Software Foundation, Inc. |
b578f267 | 4 | |
55535639 PJ |
5 | ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de> |
6 | ;; Modified by: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk> | |
7 | ;; Maintainer: FSF | |
8 | ;; Keywords: unix, dired | |
d88c0e93 | 9 | |
b578f267 | 10 | ;; This file is part of GNU Emacs. |
d88c0e93 | 11 | |
b578f267 | 12 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
d88c0e93 | 13 | ;; it under the terms of the GNU General Public License as published by |
7c938215 | 14 | ;; the Free Software Foundation; either version 2, or (at your option) |
d88c0e93 | 15 | ;; any later version. |
b578f267 EN |
16 | |
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
d88c0e93 SK |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
b578f267 | 21 | |
d88c0e93 | 22 | ;; You should have received a copy of the GNU General Public License |
b578f267 EN |
23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
24 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
25 | ;; Boston, MA 02111-1307, USA. | |
26 | ||
27 | ;;; Commentary: | |
738eb4e7 | 28 | |
3f51f5a9 | 29 | ;; OVERVIEW ========================================================== |
d9a0f717 | 30 | |
3f51f5a9 EZ |
31 | ;; This file redefines the function `insert-directory' to implement it |
32 | ;; directly from Emacs lisp, without running ls in a subprocess. It | |
33 | ;; is useful if you cannot afford to fork Emacs on a real memory UNIX, | |
34 | ;; under VMS or other non-UNIX platforms if you don't have the ls | |
35 | ;; program, or if you want a different format from what ls offers. | |
738eb4e7 | 36 | |
3f51f5a9 EZ |
37 | ;; This function can use regexps instead of shell wildcards. If you |
38 | ;; enter regexps remember to double each $ sign. For example, to | |
39 | ;; include files *.el, enter `.*\.el$$', resulting in the regexp | |
40 | ;; `.*\.el$'. | |
738eb4e7 | 41 | |
3f51f5a9 | 42 | ;; RESTRICTIONS ====================================================== |
738eb4e7 | 43 | |
3f51f5a9 EZ |
44 | ;; * A few obscure ls switches are still ignored: see the docstring of |
45 | ;; `insert-directory'. | |
d88c0e93 | 46 | |
3f51f5a9 | 47 | ;; * Generally only numeric uid/gid. |
d88c0e93 | 48 | |
3f51f5a9 | 49 | ;; TO DO ============================================================= |
738eb4e7 | 50 | |
3f51f5a9 | 51 | ;; Complete handling of F switch (if/when possible). |
738eb4e7 | 52 | |
3f51f5a9 EZ |
53 | ;; FJW: May be able to sort much faster by consing the sort key onto |
54 | ;; the front of each list element, sorting and then stripping the key | |
55 | ;; off again! | |
738eb4e7 | 56 | |
3f51f5a9 | 57 | ;;; History: |
76550a57 | 58 | |
3f51f5a9 EZ |
59 | ;; Written originally by Sebastian Kremer <sk@thp.uni-koeln.de> |
60 | ;; Revised by Andrew Innes and Geoff Volker (and maybe others). | |
3045b163 | 61 | |
3f51f5a9 EZ |
62 | ;; Modified by Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>, mainly |
63 | ;; to support many more ls options, "platform emulation", hooks for | |
64 | ;; external symbolic link support and more robust sorting. | |
65 | ||
66 | ;;; Code: | |
97b927b3 | 67 | |
3f51f5a9 EZ |
68 | ;;;###autoload |
69 | (defgroup ls-lisp nil | |
70 | "Emulate the ls program completely in Emacs Lisp." | |
eff409ba | 71 | :version "21.1" |
3f51f5a9 EZ |
72 | :group 'dired) |
73 | ||
74 | (defcustom ls-lisp-emulation | |
75 | (cond ((eq system-type 'macos) 'MacOS) | |
76 | ;; ((eq system-type 'windows-nt) 'MS-Windows) | |
77 | ((memq system-type | |
78 | '(hpux dgux usg-unix-v unisoft-unix rtu irix berkeley-unix)) | |
79 | 'UNIX)) ; very similar to GNU | |
80 | ;; Anything else defaults to nil, meaning GNU. | |
81 | "*Platform to emulate: GNU (default), MacOS, MS-Windows, UNIX. | |
82 | Corresponding value is one of the atoms: nil, MacOS, MS-Windows, UNIX. | |
83 | Sets default values for: `ls-lisp-ignore-case', `ls-lisp-dirs-first', | |
84 | `ls-lisp-verbosity'. Need not match actual platform. Changing this | |
85 | option will have no effect until you restart Emacs." | |
86 | :type '(choice (const :tag "GNU" nil) | |
87 | (const MacOS) | |
88 | (const MS-Windows) | |
89 | (const UNIX)) | |
90 | :group 'ls-lisp) | |
91 | ||
92 | (defcustom ls-lisp-ignore-case | |
93 | ;; Name change for consistency with other option names. | |
94 | (or (memq ls-lisp-emulation '(MS-Windows MacOS)) | |
95 | (and (boundp 'ls-lisp-dired-ignore-case) ls-lisp-dired-ignore-case)) | |
96 | "*Non-nil causes ls-lisp alphabetic sorting to ignore case." | |
97 | :type 'boolean | |
98 | :group 'ls-lisp) | |
99 | ||
100 | (defcustom ls-lisp-dirs-first (eq ls-lisp-emulation 'MS-Windows) | |
101 | "*Non-nil causes ls-lisp to sort directories first in any ordering. | |
102 | \(Or last if it is reversed.) Follows Microsoft Windows Explorer." | |
103 | ;; Functionality suggested by Chris McMahan <cmcmahan@one.net> | |
104 | :type 'boolean | |
105 | :group 'ls-lisp) | |
106 | ||
107 | (defcustom ls-lisp-verbosity | |
108 | (cond ((eq ls-lisp-emulation 'MacOS) nil) | |
109 | ((eq ls-lisp-emulation 'MS-Windows) | |
110 | (if (and (fboundp 'w32-using-nt) (w32-using-nt)) | |
111 | '(links))) ; distinguish NT/2K from 9x | |
112 | ((eq ls-lisp-emulation 'UNIX) '(links uid)) ; UNIX ls | |
113 | (t '(links uid gid))) ; GNU ls | |
114 | "*A list of optional file attributes that ls-lisp should display. | |
115 | It should contain none or more of the symbols: links, uid, gid. | |
116 | Nil (or an empty list) means display none of them. | |
117 | ||
118 | Concepts come from UNIX: `links' means count of names associated with | |
119 | the file\; `uid' means user (owner) identifier\; `gid' means group | |
120 | identifier. | |
121 | ||
122 | If emulation is MacOS then default is nil\; | |
123 | if emulation is MS-Windows then default is `(links)' if platform is | |
124 | Windows NT/2K, nil otherwise\; | |
125 | if emulation is UNIX then default is `(links uid)'\; | |
126 | if emulation is GNU then default is `(links uid gid)'." | |
127 | ;; Functionality suggested by Howard Melman <howard@silverstream.com> | |
128 | :type '(set (const :tag "Show Link Count" links) | |
129 | (const :tag "Show User" uid) | |
130 | (const :tag "Show Group" gid)) | |
131 | :group 'ls-lisp) | |
132 | ||
133 | (defcustom ls-lisp-use-insert-directory-program nil | |
134 | "*Non-nil causes ls-lisp to revert back to using `insert-directory-program'. | |
0cb0ba6c GV |
135 | This is useful on platforms where ls-lisp is dumped into Emacs, such as |
136 | Microsoft Windows, but you would still like to use a program to list | |
3f51f5a9 EZ |
137 | the contents of a directory." |
138 | :type 'boolean | |
139 | :group 'ls-lisp) | |
140 | ||
141 | (defcustom ls-lisp-support-shell-wildcards t | |
142 | "*Non-nil means ls-lisp treats file patterns as shell wildcards. | |
143 | Otherwise they are treated as Emacs regexps (for backward compatibility)." | |
144 | :type 'boolean | |
145 | :group 'ls-lisp) | |
146 | ||
147 | ;; Remember the original insert-directory function | |
148 | (or (featurep 'ls-lisp) ; FJW: unless this file is being reloaded! | |
149 | (fset 'original-insert-directory (symbol-function 'insert-directory))) | |
150 | ||
151 | ;; This stub is to allow ls-lisp to parse symbolic links via another | |
152 | ;; library such as w32-symlinks.el from | |
153 | ;; http://centaur.qmw.ac.uk/Emacs/: | |
154 | (defun ls-lisp-parse-symlink (file-name) | |
155 | "This stub may be redefined to parse FILE-NAME as a symlink. | |
156 | It should return nil or the link target as a string." | |
157 | nil) | |
0cb0ba6c | 158 | |
3f51f5a9 EZ |
159 | \f |
160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
0cb0ba6c GV |
161 | |
162 | (defun insert-directory (file switches &optional wildcard full-directory-p) | |
163 | "Insert directory listing for FILE, formatted according to SWITCHES. | |
164 | Leaves point after the inserted text. | |
165 | SWITCHES may be a string of options, or a list of strings. | |
166 | Optional third arg WILDCARD means treat FILE as shell wildcard. | |
167 | Optional fourth arg FULL-DIRECTORY-P means file is a directory and | |
168 | switches do not contain `d', so that a full listing is expected. | |
169 | ||
3f51f5a9 EZ |
170 | This version of the function comes from `ls-lisp.el'. |
171 | If the value of `ls-lisp-use-insert-directory-program' is non-nil then | |
172 | it works exactly like the version from `files.el' and runs a directory | |
173 | listing program whose name is in the variable | |
174 | `insert-directory-program'; if also WILDCARD is non-nil then it runs | |
175 | the shell specified by `shell-file-name'. If the value of | |
176 | `ls-lisp-use-insert-directory-program' is nil then it runs a Lisp | |
177 | emulation. | |
178 | ||
179 | The Lisp emulation does not run any external programs or shells. It | |
180 | supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards' | |
181 | is non-nil; otherwise, it interprets wildcards as regular expressions | |
182 | to match file names. It does not support all `ls' switches -- those | |
183 | that work are: A a c i r S s t u U X g G B C R and F partly." | |
0cb0ba6c GV |
184 | (if ls-lisp-use-insert-directory-program |
185 | (original-insert-directory file switches wildcard full-directory-p) | |
3f51f5a9 EZ |
186 | ;; We need the directory in order to find the right handler. |
187 | (let ((handler (find-file-name-handler (expand-file-name file) | |
188 | 'insert-directory))) | |
189 | (if handler | |
190 | (funcall handler 'insert-directory file switches | |
191 | wildcard full-directory-p) | |
192 | ;; Convert SWITCHES to a list of characters. | |
193 | (setq switches (delete ?- (append switches nil))) | |
194 | (if wildcard | |
195 | (setq wildcard | |
196 | (if ls-lisp-support-shell-wildcards | |
197 | (wildcard-to-regexp (file-name-nondirectory file)) | |
198 | (file-name-nondirectory file)) | |
199 | file (file-name-directory file)) | |
200 | (if (memq ?B switches) (setq wildcard "[^~]\\'"))) | |
201 | (ls-lisp-insert-directory | |
202 | file switches (ls-lisp-time-index switches) | |
203 | wildcard full-directory-p))))) | |
204 | ||
205 | (defun ls-lisp-insert-directory | |
206 | (file switches time-index wildcard full-directory-p) | |
3045b163 | 207 | "Insert directory listing for FILE, formatted according to SWITCHES. |
3f51f5a9 EZ |
208 | Leaves point after the inserted text. This is an internal function |
209 | optionally called by the `ls-lisp.el' version of `insert-directory'. | |
210 | It is called recursively if the -R switch is used. | |
211 | SWITCHES is a *list* of characters. TIME-INDEX is the time index into | |
212 | file-attributes according to SWITCHES. WILDCARD is nil or an *Emacs | |
213 | regexp*. FULL-DIRECTORY-P means file is a directory and SWITCHES does | |
214 | not contain `d', so that a full listing is expected." | |
215 | ;; Sometimes we get ".../foo*/" as FILE. While the shell and | |
216 | ;; `ls' don't mind, we certainly do, because it makes us think | |
217 | ;; there is no wildcard, only a directory name. | |
218 | (if (and ls-lisp-support-shell-wildcards | |
219 | (string-match "[[?*]" file)) | |
220 | (progn | |
221 | (or (not (eq (aref file (1- (length file))) ?/)) | |
222 | (setq file (substring file 0 (1- (length file))))) | |
223 | (setq wildcard t))) | |
224 | (if (or wildcard full-directory-p) | |
225 | (let* ((dir (file-name-as-directory file)) | |
226 | (default-directory dir) ; so that file-attributes works | |
227 | (file-alist | |
228 | (directory-files-and-attributes dir nil wildcard t)) | |
229 | (now (current-time)) | |
230 | (sum 0) | |
231 | ;; do all bindings here for speed | |
232 | total-line files elt short file-size fil attr) | |
233 | (cond ((memq ?A switches) | |
234 | (setq file-alist | |
235 | (ls-lisp-delete-matching "^\\.\\.?$" file-alist))) | |
236 | ((not (memq ?a switches)) | |
237 | ;; if neither -A nor -a, flush . files | |
238 | (setq file-alist | |
239 | (ls-lisp-delete-matching "^\\." file-alist)))) | |
240 | (setq file-alist | |
241 | (ls-lisp-handle-switches file-alist switches)) | |
242 | (if (memq ?C switches) ; column (-C) format | |
243 | (ls-lisp-column-format file-alist) | |
244 | (setq total-line (cons (point) (car-safe file-alist))) | |
245 | (setq files file-alist) | |
246 | (while files ; long (-l) format | |
247 | (setq elt (car files) | |
248 | files (cdr files) | |
249 | short (car elt) | |
250 | attr (cdr elt) | |
251 | file-size (nth 7 attr)) | |
252 | (and attr | |
253 | (setq sum (+ file-size | |
254 | ;; Even if neither SUM nor file's size | |
255 | ;; overflow, their sum could. | |
256 | (if (or (< sum (- 134217727 file-size)) | |
257 | (floatp sum) | |
258 | (floatp file-size)) | |
259 | sum | |
260 | (float sum)))) | |
261 | (insert (ls-lisp-format short attr file-size | |
262 | switches time-index now)))) | |
263 | ;; Insert total size of all files: | |
264 | (save-excursion | |
265 | (goto-char (car total-line)) | |
266 | (or (cdr total-line) | |
267 | ;; Shell says ``No match'' if no files match | |
268 | ;; the wildcard; let's say something similar. | |
269 | (insert "(No match)\n")) | |
270 | (insert (format "total %.0f\n" (fceiling (/ sum 1024.0)))))) | |
271 | (if (memq ?R switches) | |
272 | ;; List the contents of all directories recursively. | |
273 | ;; cadr of each element of `file-alist' is t for | |
274 | ;; directory, string (name linked to) for symbolic | |
275 | ;; link, or nil. | |
9dce08b6 RS |
276 | (while file-alist |
277 | (setq elt (car file-alist) | |
3f51f5a9 EZ |
278 | file-alist (cdr file-alist)) |
279 | (when (and (eq (cadr elt) t) ; directory | |
280 | (not (string-match "\\`\\.\\.?\\'" (car elt)))) | |
281 | (setq elt (expand-file-name (car elt) dir)) | |
282 | (insert "\n" elt ":\n") | |
283 | (ls-lisp-insert-directory | |
284 | elt switches time-index wildcard full-directory-p))))) | |
285 | ;; If not full-directory-p, FILE *must not* end in /, as | |
286 | ;; file-attributes will not recognize a symlink to a directory, | |
287 | ;; so must make it a relative filename as ls does: | |
288 | (if (eq (aref file (1- (length file))) ?/) | |
289 | (setq file (substring file 0 -1))) | |
290 | (let ((fattr (file-attributes file))) | |
291 | (if fattr | |
292 | (insert (ls-lisp-format file fattr (nth 7 fattr) | |
293 | switches time-index (current-time))) | |
294 | (message "%s: doesn't exist or is inaccessible" file) | |
295 | (ding) (sit-for 2))))) ; to show user the message! | |
296 | ||
297 | (defun ls-lisp-column-format (file-alist) | |
298 | "Insert the file names (only) in FILE-ALIST into the current buffer. | |
299 | Format in columns, sorted vertically, following GNU ls -C. | |
300 | Responds to the window width as ls should but may not!" | |
301 | (let (files fmt ncols collen (nfiles 0) (colwid 0)) | |
302 | ;; Count number of files as `nfiles', build list of filenames as | |
303 | ;; `files', and find maximum filename length as `colwid': | |
304 | (let (file len) | |
305 | (while file-alist | |
306 | (setq nfiles (1+ nfiles) | |
307 | file (caar file-alist) | |
308 | files (cons file files) | |
309 | file-alist (cdr file-alist) | |
310 | len (length file)) | |
311 | (if (> len colwid) (setq colwid len)))) | |
312 | (setq files (nreverse files) | |
313 | colwid (+ 2 colwid) ; 2 character column gap | |
314 | fmt (format "%%-%ds" colwid) ; print format | |
315 | ncols (/ (window-width) colwid) ; no of columns | |
316 | collen (/ nfiles ncols)) ; floor of column length | |
317 | (if (> nfiles (* collen ncols)) (setq collen (1+ collen))) | |
318 | ;; Output the file names in columns, sorted vertically: | |
319 | (let ((i 0) j) | |
320 | (while (< i collen) | |
321 | (setq j i) | |
322 | (while (< j nfiles) | |
323 | (insert (format fmt (nth j files))) | |
324 | (setq j (+ j collen))) | |
325 | ;; FJW: This is completely unnecessary, but I don't like | |
326 | ;; trailing white space... | |
327 | (delete-region (point) (progn (skip-chars-backward " \t") (point))) | |
328 | (insert ?\n) | |
329 | (setq i (1+ i)))))) | |
9dce08b6 RS |
330 | |
331 | (defun ls-lisp-delete-matching (regexp list) | |
3f51f5a9 | 332 | "Delete all elements matching REGEXP from LIST, return new list." |
d6d472d5 | 333 | ;; Should perhaps use setcdr for efficiency. |
6467926f SK |
334 | (let (result) |
335 | (while list | |
3f51f5a9 | 336 | (or (string-match regexp (caar list)) |
6467926f SK |
337 | (setq result (cons (car list) result))) |
338 | (setq list (cdr list))) | |
339 | result)) | |
340 | ||
3f51f5a9 EZ |
341 | (defsubst ls-lisp-string-lessp (s1 s2) |
342 | "Return t if string S1 is less than string S2 in lexicographic order. | |
343 | Case is significant if `ls-lisp-ignore-case' is nil. | |
344 | Unibyte strings are converted to multibyte for comparison." | |
345 | (let ((u (compare-strings s1 0 nil s2 0 nil ls-lisp-ignore-case))) | |
346 | (and (numberp u) (< u 0)))) | |
347 | ||
9dce08b6 | 348 | (defun ls-lisp-handle-switches (file-alist switches) |
3f51f5a9 EZ |
349 | "Return new FILE-ALIST sorted according to SWITCHES. |
350 | SWITCHES is a list of characters. Default sorting is alphabetic." | |
6467926f | 351 | ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES). |
3f51f5a9 EZ |
352 | (or (memq ?U switches) ; unsorted |
353 | ;; Catch and ignore unexpected sorting errors | |
354 | (condition-case err | |
355 | (setq file-alist | |
356 | (let (index) | |
357 | ;; Copy file-alist in case of error | |
358 | (sort (copy-sequence file-alist) ; modifies its argument! | |
359 | (cond ((memq ?S switches) | |
360 | (lambda (x y) ; sorted on size | |
361 | ;; 7th file attribute is file size | |
362 | ;; Make largest file come first | |
363 | (< (nth 7 (cdr y)) | |
364 | (nth 7 (cdr x))))) | |
365 | ((setq index (ls-lisp-time-index switches)) | |
366 | (lambda (x y) ; sorted on time | |
367 | (ls-lisp-time-lessp (nth index (cdr y)) | |
368 | (nth index (cdr x))))) | |
369 | ((memq ?X switches) | |
370 | (lambda (x y) ; sorted on extension | |
371 | (ls-lisp-string-lessp | |
372 | (ls-lisp-extension (car x)) | |
373 | (ls-lisp-extension (car y))))) | |
374 | (t | |
375 | (lambda (x y) ; sorted alphabetically | |
376 | (ls-lisp-string-lessp (car x) (car y)))))))) | |
377 | (error (message "Unsorted (ls-lisp sorting error) - %s" | |
378 | (error-message-string err)) | |
379 | (ding) (sit-for 2)))) ; to show user the message! | |
380 | (if (memq ?F switches) ; classify switch | |
381 | (setq file-alist (mapcar 'ls-lisp-classify file-alist))) | |
382 | (if ls-lisp-dirs-first | |
383 | ;; Re-sort directories first, without otherwise changing the | |
384 | ;; ordering, and reverse whole list. cadr of each element of | |
385 | ;; `file-alist' is t for directory, string (name linked to) for | |
386 | ;; symbolic link, or nil. | |
387 | (let (el dirs files) | |
388 | (while file-alist | |
389 | (if (eq (cadr (setq el (car file-alist))) t) ; directory | |
390 | (setq dirs (cons el dirs)) | |
391 | (setq files (cons el files))) | |
392 | (setq file-alist (cdr file-alist))) | |
393 | (setq file-alist | |
394 | (if (memq ?U switches) ; unsorted order is reversed | |
395 | (nconc dirs files) | |
396 | (nconc files dirs) | |
397 | )))) | |
398 | ;; Finally reverse file alist if necessary. | |
399 | ;; (eq below MUST compare `(not (memq ...))' to force comparison of | |
400 | ;; `t' or `nil', rather than list tails!) | |
401 | (if (eq (eq (not (memq ?U switches)) ; unsorted order is reversed | |
402 | (not (memq ?r switches))) ; reversed sort order requested | |
403 | ls-lisp-dirs-first) ; already reversed | |
404 | (nreverse file-alist) | |
405 | file-alist)) | |
406 | ||
407 | (defun ls-lisp-classify (filedata) | |
408 | "Append a character to each file name indicating the file type. | |
409 | Also, for regular files that are executable, append `*'. | |
410 | The file type indicators are `/' for directories, `@' for symbolic | |
411 | links, `|' for FIFOs, `=' for sockets, and nothing for regular files. | |
412 | \[But FIFOs and sockets are not recognised.] | |
413 | FILEDATA has the form (filename . `file-attributes'). Its `cadr' is t | |
414 | for directory, string (name linked to) for symbolic link, or nil." | |
415 | (let ((dir (cadr filedata)) (file-name (car filedata))) | |
416 | (cond ((or dir | |
417 | ;; Parsing .lnk files here is perhaps overkill! | |
418 | (setq dir (ls-lisp-parse-symlink file-name))) | |
419 | (cons | |
420 | (concat file-name (if (eq dir t) "/" "@")) | |
421 | (cdr filedata))) | |
422 | ((string-match "x" (nth 9 filedata)) | |
423 | (cons | |
424 | (concat file-name "*") | |
425 | (cdr filedata))) | |
426 | (t filedata)))) | |
427 | ||
428 | (defun ls-lisp-extension (filename) | |
429 | "Return extension of FILENAME (ignoring any version extension) | |
430 | FOLLOWED by null and full filename, SOLELY for full alpha sort." | |
431 | ;; Force extension sort order: `no ext' then `null ext' then `ext' | |
432 | ;; to agree with GNU ls. | |
433 | (concat | |
434 | (let* ((i (length filename)) end) | |
435 | (if (= (aref filename (1- i)) ?.) ; null extension | |
436 | "\0" | |
437 | (while (and (>= (setq i (1- i)) 0) | |
438 | (/= (aref filename i) ?.))) | |
439 | (if (< i 0) "\0\0" ; no extension | |
440 | (if (/= (aref filename (1+ i)) ?~) | |
441 | (substring filename (1+ i)) | |
442 | ;; version extension found -- ignore it | |
443 | (setq end i) | |
444 | (while (and (>= (setq i (1- i)) 0) | |
445 | (/= (aref filename i) ?.))) | |
446 | (if (< i 0) "\0\0" ; no extension | |
447 | (substring filename (1+ i) end)))) | |
448 | )) "\0" filename)) | |
d88c0e93 | 449 | |
e54241c5 | 450 | ;; From Roland McGrath. Can use this to sort on time. |
9dce08b6 | 451 | (defun ls-lisp-time-lessp (time0 time1) |
3f51f5a9 EZ |
452 | "Return t if time TIME0 is earlier than time TIME1." |
453 | (let ((hi0 (car time0)) (hi1 (car time1))) | |
e54241c5 SK |
454 | (or (< hi0 hi1) |
455 | (and (= hi0 hi1) | |
3f51f5a9 EZ |
456 | (< (cadr time0) (cadr time1)))))) |
457 | ||
458 | (defun ls-lisp-format (file-name file-attr file-size switches time-index now) | |
459 | "Format one line of long ls output for file FILE-NAME. | |
460 | FILE-ATTR and FILE-SIZE give the file's attributes and size. | |
461 | SWITCHES, TIME-INDEX and NOW give the full switch list and time data." | |
462 | (let ((file-type (nth 0 file-attr)) | |
463 | ;; t for directory, string (name linked to) | |
464 | ;; for symbolic link, or nil. | |
465 | (drwxrwxrwx (nth 8 file-attr))) ; attribute string ("drwxrwxrwx") | |
466 | (and (null file-type) | |
467 | ;; Maybe no kernel support for symlinks, so... | |
468 | (setq file-type (ls-lisp-parse-symlink file-name)) | |
469 | (aset drwxrwxrwx 0 ?l)) ; symbolic link - update attribute string | |
6467926f | 470 | (concat (if (memq ?i switches) ; inode number |
3f51f5a9 | 471 | (format " %6d" (nth 10 file-attr))) |
d6d472d5 | 472 | ;; nil is treated like "" in concat |
6467926f | 473 | (if (memq ?s switches) ; size in K |
3f51f5a9 EZ |
474 | (format " %4.0f" (fceiling (/ file-size 1024.0)))) |
475 | drwxrwxrwx ; attribute string | |
476 | (if (memq 'links ls-lisp-verbosity) | |
477 | (format " %3d" (nth 1 file-attr))) ; link count | |
478 | ;; Numeric uid/gid are more confusing than helpful; | |
6467926f | 479 | ;; Emacs should be able to make strings of them. |
3f51f5a9 EZ |
480 | ;; They tend to be bogus on non-UNIX platforms anyway so |
481 | ;; optionally hide them. | |
482 | (if (memq 'uid ls-lisp-verbosity) | |
483 | ;; (user-login-name uid) works on Windows NT but not | |
484 | ;; on 9x and maybe not on some other platforms, so... | |
485 | (let ((uid (nth 2 file-attr))) | |
486 | (if (= uid (user-uid)) | |
487 | (format " %-8s" (user-login-name)) | |
488 | (format " %-8d" uid)))) | |
489 | (if (not (memq ?G switches)) ; GNU ls -- shows group by default | |
490 | (if (or (memq ?g switches) ; UNIX ls -- no group by default | |
491 | (memq 'gid ls-lisp-verbosity)) | |
492 | (if (memq system-type '(macos windows-nt ms-dos)) | |
493 | ;; No useful concept of group... | |
9010db4c | 494 | " root" |
3f51f5a9 EZ |
495 | (let* ((gid (nth 3 file-attr)) |
496 | (group (user-login-name gid))) | |
497 | (if group | |
498 | (format " %-8s" group) | |
499 | (format " %-8d" gid)))))) | |
500 | (format (if (floatp file-size) " %8.0f" " %8d") file-size) | |
501 | " " | |
502 | (ls-lisp-format-time file-attr time-index now) | |
738eb4e7 | 503 | " " |
d88c0e93 SK |
504 | file-name |
505 | (if (stringp file-type) ; is a symbolic link | |
3f51f5a9 | 506 | (concat " -> " file-type)) |
d88c0e93 SK |
507 | "\n" |
508 | ))) | |
509 | ||
9dce08b6 | 510 | (defun ls-lisp-time-index (switches) |
3f51f5a9 EZ |
511 | "Return time index into file-attributes according to ls SWITCHES list. |
512 | Return nil if no time switch found." | |
513 | ;; FJW: Default of nil is IMPORTANT and used in `ls-lisp-handle-switches'! | |
514 | (cond ((memq ?c switches) 6) ; last mode change | |
515 | ((memq ?t switches) 5) ; last modtime | |
516 | ((memq ?u switches) 4))) ; last access | |
517 | ||
518 | (defun ls-lisp-format-time (file-attr time-index now) | |
519 | "Format time for file with attributes FILE-ATTR according to TIME-INDEX. | |
520 | Use the same method as ls to decide whether to show time-of-day or year, | |
521 | depending on distance between file date and NOW. | |
522 | All ls time options, namely c, t and u, are handled." | |
523 | (let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime | |
1fff30af RS |
524 | (diff16 (- (car time) (car now))) |
525 | (diff (+ (ash diff16 16) (- (car (cdr time)) (car (cdr now))))) | |
526 | (past-cutoff (- (* 6 30 24 60 60))) ; 6 30-day months | |
527 | (future-cutoff (* 60 60))) ; 1 hour | |
f8a10234 AI |
528 | (condition-case nil |
529 | (format-time-string | |
530 | (if (and | |
531 | (<= past-cutoff diff) (<= diff future-cutoff) | |
532 | ;; Sanity check in case `diff' computation overflowed. | |
533 | (<= (1- (ash past-cutoff -16)) diff16) | |
534 | (<= diff16 (1+ (ash future-cutoff -16)))) | |
535 | "%b %e %H:%M" | |
536 | "%b %e %Y") | |
537 | time) | |
452e47d7 | 538 | (error "Unk 0 0000")))) |
738eb4e7 | 539 | |
9dce08b6 | 540 | (provide 'ls-lisp) |
738eb4e7 | 541 | |
76550a57 | 542 | ;;; ls-lisp.el ends here |