Avoid segfaults when some display vector is an empty string
[emacs.git] / lisp / ls-lisp.el
blob7ae234344156834de6023fd7a3807585ae973fab
1 ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
3 ;; Copyright (C) 1992, 1994, 2000-2017 Free Software Foundation, Inc.
5 ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
6 ;; Modified by: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>
7 ;; Maintainer: emacs-devel@gnu.org
8 ;; Keywords: unix, dired
9 ;; Package: emacs
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;;; Commentary:
28 ;; OVERVIEW ==========================================================
30 ;; This file advises the function `insert-directory' to implement it
31 ;; directly from Emacs lisp, without running ls in a subprocess.
32 ;; This is useful if you don't have ls installed (ie, on MS Windows).
34 ;; This function can use regexps instead of shell wildcards. If you
35 ;; enter regexps remember to double each $ sign. For example, to
36 ;; include files *.el, enter `.*\.el$$', resulting in the regexp
37 ;; `.*\.el$'.
39 ;; RESTRICTIONS ======================================================
41 ;; * A few obscure ls switches are still ignored: see the docstring of
42 ;; `insert-directory'.
44 ;; TO DO =============================================================
46 ;; Complete handling of F switch (if/when possible).
48 ;; FJW: May be able to sort much faster by consing the sort key onto
49 ;; the front of each list element, sorting and then stripping the key
50 ;; off again!
52 ;;; History:
54 ;; Written originally by Sebastian Kremer <sk@thp.uni-koeln.de>
55 ;; Revised by Andrew Innes and Geoff Volker (and maybe others).
57 ;; Modified by Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>, mainly
58 ;; to support many more ls options, "platform emulation" and more
59 ;; robust sorting.
61 ;;; Code:
63 (defgroup ls-lisp nil
64 "Emulate the ls program completely in Emacs Lisp."
65 :version "21.1"
66 :group 'dired)
68 (defun ls-lisp-set-options ()
69 "Reset the ls-lisp options that depend on `ls-lisp-emulation'."
70 (mapc 'custom-reevaluate-setting
71 '(ls-lisp-ignore-case ls-lisp-dirs-first ls-lisp-verbosity)))
73 (defcustom ls-lisp-emulation
74 (cond ;; ((eq system-type 'windows-nt) 'MS-Windows)
75 ((memq system-type '(hpux usg-unix-v berkeley-unix))
76 'UNIX)) ; very similar to GNU
77 ;; Anything else defaults to nil, meaning GNU.
78 "Platform to emulate: GNU (default), macOS, MS-Windows, UNIX.
79 Corresponding value is one of: nil, `MacOS', `MS-Windows', `UNIX'.
80 Set this to your preferred value; it need not match the actual platform
81 you are using.
83 This variable does not affect the behavior of ls-lisp directly.
84 Rather, it controls the default values for some variables that do:
85 `ls-lisp-ignore-case', `ls-lisp-dirs-first', and `ls-lisp-verbosity'.
87 If you change this variable directly (without using customize)
88 after loading `ls-lisp', you should use `ls-lisp-set-options' to
89 update the dependent variables."
90 :type '(choice (const :tag "GNU" nil)
91 (const MacOS)
92 (const MS-Windows)
93 (const UNIX))
94 :initialize 'custom-initialize-default
95 :set (lambda (symbol value)
96 (unless (equal value (eval symbol))
97 (custom-set-default symbol value)
98 (ls-lisp-set-options)))
99 :group 'ls-lisp)
101 ;; Only made an obsolete alias in 23.3. Before that, the initial
102 ;; value was set according to:
103 ;; (or (memq ls-lisp-emulation '(MS-Windows MacOS))
104 ;; (and (boundp 'ls-lisp-dired-ignore-case) ls-lisp-dired-ignore-case))
105 ;; Which isn't the right thing to do.
106 (define-obsolete-variable-alias 'ls-lisp-dired-ignore-case
107 'ls-lisp-ignore-case "21.1")
109 (defcustom ls-lisp-ignore-case
110 (memq ls-lisp-emulation '(MS-Windows MacOS))
111 "Non-nil causes ls-lisp alphabetic sorting to ignore case."
112 :set-after '(ls-lisp-emulation)
113 :type 'boolean
114 :group 'ls-lisp)
116 (defcustom ls-lisp-use-string-collate
117 (cond ((memq ls-lisp-emulation '(MacOS UNIX)) nil)
118 (t t)) ; GNU/Linux or MS-Windows emulate GNU ls
119 "Non-nil causes ls-lisp to sort files in locale-dependent collation order.
121 A value of nil means use ordinary string comparison (see `compare-strings')
122 for sorting files. A non-nil value uses `string-collate-lessp' instead,
123 which more closely emulates what GNU `ls' does.
125 On GNU/Linux systems, if the locale's codeset specifies UTF-8, as
126 in \"en_US.UTF-8\", the collation order follows the Unicode
127 Collation Algorithm (UCA), which places together file names that
128 differ only in punctuation characters. On MS-Windows, customize
129 the option `ls-lisp-UCA-like-collation' to a non-nil value to get
130 similar behavior."
131 :version "25.1"
132 :set-after '(ls-lisp-emulation)
133 :type 'boolean
134 :group 'ls-lisp)
136 (defcustom ls-lisp-UCA-like-collation t
137 "Non-nil means force ls-lisp use a collation order compatible with UCA.
139 UCA is the Unicode Collation Algorithm. GNU/Linux systems automatically
140 follow it in their string-collation routines if the locale specifies
141 UTF-8 as its codeset. On MS-Windows, customize this option to a non-nil
142 value to get similar behavior.
144 When this option is non-nil, and `ls-lisp-use-string-collate' is also
145 non-nil, the collation order produced on MS-Windows will ignore
146 punctuation and symbol characters, which will, for example, place
147 `.foo' near `foo'. See the documentation of `string-collate-lessp'
148 and `w32-collate-ignore-punctuation' for more details.
150 This option is ignored on platforms other than MS-Windows; to
151 control the collation ordering of the file names on those other
152 systems, set your locale instead."
153 :version "25.1"
154 :type 'boolean
155 :group 'ls-lisp)
157 (defcustom ls-lisp-dirs-first (eq ls-lisp-emulation 'MS-Windows)
158 "Non-nil causes ls-lisp to sort directories first in any ordering.
159 \(Or last if it is reversed.) Follows Microsoft Windows Explorer."
160 ;; Functionality suggested by Chris McMahan <cmcmahan@one.net>
161 :set-after '(ls-lisp-emulation)
162 :type 'boolean
163 :group 'ls-lisp)
165 (defcustom ls-lisp-verbosity
166 (cond ((eq ls-lisp-emulation 'MacOS) nil)
167 ((eq ls-lisp-emulation 'MS-Windows)
168 (if (and (fboundp 'w32-using-nt) (w32-using-nt))
169 '(links))) ; distinguish NT/2K from 9x
170 ((eq ls-lisp-emulation 'UNIX) '(links uid)) ; UNIX ls
171 (t '(links uid gid))) ; GNU ls
172 "A list of optional file attributes that ls-lisp should display.
173 It should contain none or more of the symbols: links, uid, gid.
174 A value of nil (or an empty list) means display none of them.
176 Concepts come from UNIX: `links' means count of names associated with
177 the file; `uid' means user (owner) identifier; `gid' means group
178 identifier.
180 If emulation is MacOS then default is nil;
181 if emulation is MS-Windows then default is `(links)' if platform is
182 Windows NT/2K, nil otherwise;
183 if emulation is UNIX then default is `(links uid)';
184 if emulation is GNU then default is `(links uid gid)'."
185 :set-after '(ls-lisp-emulation)
186 ;; Functionality suggested by Howard Melman <howard@silverstream.com>
187 :type '(set (const :tag "Show Link Count" links)
188 (const :tag "Show User" uid)
189 (const :tag "Show Group" gid))
190 :group 'ls-lisp)
192 (defcustom ls-lisp-use-insert-directory-program
193 (not (memq system-type '(ms-dos windows-nt)))
194 "Non-nil causes ls-lisp to revert back to using `insert-directory-program'.
195 This is useful on platforms where ls-lisp is dumped into Emacs, such as
196 Microsoft Windows, but you would still like to use a program to list
197 the contents of a directory."
198 :type 'boolean
199 :group 'ls-lisp)
201 ;;; Autoloaded because it is let-bound in `recover-session', `mail-recover-1'.
202 ;;;###autoload
203 (defcustom ls-lisp-support-shell-wildcards t
204 "Non-nil means ls-lisp treats file patterns as shell wildcards.
205 Otherwise they are treated as Emacs regexps (for backward compatibility)."
206 :type 'boolean
207 :group 'ls-lisp)
209 (defcustom ls-lisp-format-time-list
210 '("%b %e %H:%M"
211 "%b %e %Y")
212 "List of `format-time-string' specs to display file time stamps.
213 These specs are used ONLY if a valid locale can not be determined.
215 If `ls-lisp-use-localized-time-format' is non-nil, these specs are used
216 regardless of whether the locale can be determined.
218 Syntax: (EARLY-TIME-FORMAT OLD-TIME-FORMAT)
220 The EARLY-TIME-FORMAT is used if file has been modified within the
221 current year. The OLD-TIME-FORMAT is used for older files. To use ISO
222 8601 dates, you could set:
224 \(setq ls-lisp-format-time-list
225 \\='(\"%Y-%m-%d %H:%M\"
226 \"%Y-%m-%d \"))"
227 :type '(list (string :tag "Early time format")
228 (string :tag "Old time format"))
229 :group 'ls-lisp)
231 (defcustom ls-lisp-use-localized-time-format nil
232 "Non-nil means to always use `ls-lisp-format-time-list' for time stamps.
233 This applies even if a valid locale is specified.
235 WARNING: Using localized date/time format might cause Dired columns
236 to fail to line up, e.g. if month names are not all of the same length."
237 :type 'boolean
238 :group 'ls-lisp)
240 (defvar ls-lisp-uid-d-fmt " %d"
241 "Format to display integer UIDs.")
242 (defvar ls-lisp-uid-s-fmt " %s"
243 "Format to display user names.")
244 (defvar ls-lisp-gid-d-fmt " %d"
245 "Format to display integer GIDs.")
246 (defvar ls-lisp-gid-s-fmt " %s"
247 "Format to display user group names.")
248 (defvar ls-lisp-filesize-d-fmt "%d"
249 "Format to display integer file sizes.")
250 (defvar ls-lisp-filesize-f-fmt "%.0f"
251 "Format to display float file sizes.")
252 (defvar ls-lisp-filesize-b-fmt "%.0f"
253 "Format to display file sizes in blocks (for the -s switch).")
255 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257 (defun ls-lisp--insert-directory (orig-fun file switches &optional wildcard full-directory-p)
258 "Insert directory listing for FILE, formatted according to SWITCHES.
259 Leaves point after the inserted text.
260 SWITCHES may be a string of options, or a list of strings.
261 Optional third arg WILDCARD means treat FILE as shell wildcard.
262 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
263 switches do not contain `d', so that a full listing is expected.
265 This version of the function comes from `ls-lisp.el'.
266 If the value of `ls-lisp-use-insert-directory-program' is non-nil then
267 this advice just delegates the work to ORIG-FUN (the normal `insert-directory'
268 function from `files.el').
269 But if the value of `ls-lisp-use-insert-directory-program' is nil
270 then it runs a Lisp emulation.
272 The Lisp emulation does not run any external programs or shells. It
273 supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards'
274 is non-nil; otherwise, it interprets wildcards as regular expressions
275 to match file names. It does not support all `ls' switches -- those
276 that work are: A a B C c F G g h i n R r S s t U u v X. The l switch
277 is assumed to be always present and cannot be turned off."
278 (if ls-lisp-use-insert-directory-program
279 (funcall orig-fun
280 file switches wildcard full-directory-p)
281 ;; We need the directory in order to find the right handler.
282 (let ((handler (find-file-name-handler (expand-file-name file)
283 'insert-directory))
284 (orig-file file)
285 wildcard-regexp)
286 (if handler
287 (funcall handler 'insert-directory file switches
288 wildcard full-directory-p)
289 ;; Remove --dired switch
290 (if (string-match "--dired " switches)
291 (setq switches (replace-match "" nil nil switches)))
292 ;; Convert SWITCHES to a list of characters.
293 (setq switches (delete ?\ (delete ?- (append switches nil))))
294 ;; Sometimes we get ".../foo*/" as FILE. While the shell and
295 ;; `ls' don't mind, we certainly do, because it makes us think
296 ;; there is no wildcard, only a directory name.
297 (if (and ls-lisp-support-shell-wildcards
298 (string-match "[[?*]" file)
299 ;; Prefer an existing file to wildcards, like
300 ;; dired-noselect does.
301 (not (file-exists-p file)))
302 (progn
303 (or (not (eq (aref file (1- (length file))) ?/))
304 (setq file (substring file 0 (1- (length file)))))
305 (setq wildcard t)))
306 (if wildcard
307 (setq wildcard-regexp
308 (if ls-lisp-support-shell-wildcards
309 (wildcard-to-regexp (file-name-nondirectory file))
310 (file-name-nondirectory file))
311 file (file-name-directory file))
312 (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
313 (condition-case err
314 (ls-lisp-insert-directory
315 file switches (ls-lisp-time-index switches)
316 wildcard-regexp full-directory-p)
317 (invalid-regexp
318 ;; Maybe they wanted a literal file that just happens to
319 ;; use characters special to shell wildcards.
320 (if (equal (cadr err) "Unmatched [ or [^")
321 (progn
322 (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'")
323 file (file-relative-name orig-file))
324 (ls-lisp-insert-directory
325 file switches (ls-lisp-time-index switches)
326 nil full-directory-p))
327 (signal (car err) (cdr err)))))
328 ;; Try to insert the amount of free space.
329 (save-excursion
330 (goto-char (point-min))
331 ;; First find the line to put it on.
332 (when (re-search-forward "^total" nil t)
333 (let ((available (get-free-disk-space ".")))
334 (when available
335 ;; Replace "total" with "total used", to avoid confusion.
336 (replace-match "total used in directory")
337 (end-of-line)
338 (insert " available " available)))))))))
339 (advice-add 'insert-directory :around #'ls-lisp--insert-directory)
341 (defun ls-lisp-insert-directory
342 (file switches time-index wildcard-regexp full-directory-p)
343 "Insert directory listing for FILE, formatted according to SWITCHES.
344 Leaves point after the inserted text. This is an internal function
345 optionally called by the `ls-lisp.el' version of `insert-directory'.
346 It is called recursively if the -R switch is used.
347 SWITCHES is a *list* of characters. TIME-INDEX is the time index into
348 file-attributes according to SWITCHES. WILDCARD-REGEXP is nil or an *Emacs
349 regexp*. FULL-DIRECTORY-P means file is a directory and SWITCHES does
350 not contain `d', so that a full listing is expected."
351 (if (or (and wildcard-regexp
352 (not (string= "[^~]\\'" wildcard-regexp))) ; Switch -B pseudo-wildcard regexp
353 full-directory-p)
354 (let* ((dir (file-name-as-directory file))
355 (default-directory dir) ; so that file-attributes works
356 (file-alist
357 (directory-files-and-attributes dir nil wildcard-regexp t
358 (if (memq ?n switches)
359 'integer
360 'string)))
361 (sum 0)
362 (max-uid-len 0)
363 (max-gid-len 0)
364 (max-file-size 0)
365 ;; do all bindings here for speed
366 total-line files elt short file-size attr
367 fuid fgid uid-len gid-len)
368 (setq file-alist (ls-lisp-sanitize file-alist))
369 (cond ((memq ?A switches)
370 (setq file-alist
371 (ls-lisp-delete-matching "^\\.\\.?$" file-alist)))
372 ((not (memq ?a switches))
373 ;; if neither -A nor -a, flush . files
374 (setq file-alist
375 (ls-lisp-delete-matching "^\\." file-alist))))
376 (setq file-alist
377 (ls-lisp-handle-switches file-alist switches))
378 (if (memq ?C switches) ; column (-C) format
379 (ls-lisp-column-format file-alist)
380 (setq total-line (cons (point) (car-safe file-alist)))
381 ;; Find the appropriate format for displaying uid, gid, and
382 ;; file size, by finding the longest strings among all the
383 ;; files we are about to display.
384 (dolist (elt file-alist)
385 (setq attr (cdr elt)
386 fuid (nth 2 attr)
387 uid-len (if (stringp fuid) (string-width fuid)
388 (length (format "%d" fuid)))
389 fgid (nth 3 attr)
390 gid-len (if (stringp fgid) (string-width fgid)
391 (length (format "%d" fgid)))
392 file-size (nth 7 attr))
393 (if (> uid-len max-uid-len)
394 (setq max-uid-len uid-len))
395 (if (> gid-len max-gid-len)
396 (setq max-gid-len gid-len))
397 (if (> file-size max-file-size)
398 (setq max-file-size file-size)))
399 (setq ls-lisp-uid-d-fmt (format " %%-%dd" max-uid-len))
400 (setq ls-lisp-uid-s-fmt (format " %%-%ds" max-uid-len))
401 (setq ls-lisp-gid-d-fmt (format " %%-%dd" max-gid-len))
402 (setq ls-lisp-gid-s-fmt (format " %%-%ds" max-gid-len))
403 (setq ls-lisp-filesize-d-fmt
404 (format " %%%dd" (length (format "%.0f" max-file-size))))
405 (setq ls-lisp-filesize-f-fmt
406 (format " %%%d.0f" (length (format "%.0f" max-file-size))))
407 (if (memq ?s switches)
408 (setq ls-lisp-filesize-b-fmt
409 (format "%%%d.0f "
410 (length (format "%.0f"
411 (fceiling
412 (/ max-file-size 1024.0)))))))
413 (setq files file-alist)
414 (while files ; long (-l) format
415 (setq elt (car files)
416 files (cdr files)
417 short (car elt)
418 attr (cdr elt)
419 file-size (nth 7 attr))
420 (and attr
421 (setq sum (+ file-size
422 ;; Even if neither SUM nor file's size
423 ;; overflow, their sum could.
424 (if (or (< sum (- 134217727 file-size))
425 (floatp sum)
426 (floatp file-size))
428 (float sum))))
429 (insert (ls-lisp-format short attr file-size
430 switches time-index))))
431 ;; Insert total size of all files:
432 (save-excursion
433 (goto-char (car total-line))
434 (or (cdr total-line)
435 ;; Shell says ``No match'' if no files match
436 ;; the wildcard; let's say something similar.
437 (insert "(No match)\n"))
438 (insert (format "total %.0f\n" (fceiling (/ sum 1024.0))))))
439 ;; dired-insert-directory expects to find point after the
440 ;; text. But if the listing is empty, as e.g. in empty
441 ;; directories with -a removed from switches, point will be
442 ;; before the inserted text, and dired-insert-directory will
443 ;; not indent the listing correctly. Going to the end of the
444 ;; buffer fixes that.
445 (unless files (goto-char (point-max)))
446 (if (memq ?R switches)
447 ;; List the contents of all directories recursively.
448 ;; cadr of each element of `file-alist' is t for
449 ;; directory, string (name linked to) for symbolic
450 ;; link, or nil.
451 (while file-alist
452 (setq elt (car file-alist)
453 file-alist (cdr file-alist))
454 (when (and (eq (cadr elt) t) ; directory
455 ;; Under -F, we have already decorated all
456 ;; directories, including "." and "..", with
457 ;; a /, so allow for that as well.
458 (not (string-match "\\`\\.\\.?/?\\'" (car elt))))
459 (setq elt (expand-file-name (car elt) dir))
460 (insert "\n" elt ":\n")
461 (ls-lisp-insert-directory
462 elt switches time-index wildcard-regexp full-directory-p)))))
463 ;; If not full-directory-p, FILE *must not* end in /, as
464 ;; file-attributes will not recognize a symlink to a directory,
465 ;; so must make it a relative filename as ls does:
466 (if (file-name-absolute-p file) (setq file (expand-file-name file)))
467 (if (eq (aref file (1- (length file))) ?/)
468 (setq file (substring file 0 -1)))
469 (let ((fattr (file-attributes file 'string)))
470 (if fattr
471 (insert (ls-lisp-format
472 (if (memq ?F switches)
473 (ls-lisp-classify-file file fattr)
474 file)
475 fattr (nth 7 fattr)
476 switches time-index))
477 (message "%s: doesn't exist or is inaccessible" file)
478 (ding) (sit-for 2))))) ; to show user the message!
480 (defun ls-lisp-sanitize (file-alist)
481 "Sanitize the elements in FILE-ALIST.
482 Fixes any elements in the alist for directory entries whose file
483 attributes are nil (meaning that `file-attributes' failed for
484 them). This is known to happen for some network shares, in
485 particular for the \"..\" directory entry.
487 If the \"..\" directory entry has nil attributes, the attributes
488 are copied from the \".\" entry, if they are non-nil. Otherwise,
489 the offending element is removed from the list, as are any
490 elements for other directory entries with nil attributes."
491 (if (and (null (cdr (assoc ".." file-alist)))
492 (cdr (assoc "." file-alist)))
493 (setcdr (assoc ".." file-alist) (cdr (assoc "." file-alist))))
494 (rassq-delete-all nil file-alist))
496 (defun ls-lisp-column-format (file-alist)
497 "Insert the file names (only) in FILE-ALIST into the current buffer.
498 Format in columns, sorted vertically, following GNU ls -C.
499 Responds to the window width as ls should but may not!"
500 (let (files fmt ncols collen (nfiles 0) (colwid 0))
501 ;; Count number of files as `nfiles', build list of filenames as
502 ;; `files', and find maximum filename length as `colwid':
503 (let (file len)
504 (while file-alist
505 (setq nfiles (1+ nfiles)
506 file (caar file-alist)
507 files (cons file files)
508 file-alist (cdr file-alist)
509 len (length file))
510 (if (> len colwid) (setq colwid len))))
511 (setq files (nreverse files)
512 colwid (+ 2 colwid) ; 2 character column gap
513 fmt (format "%%-%ds" colwid) ; print format
514 ncols (/ (window-width) colwid) ; no of columns
515 collen (/ nfiles ncols)) ; floor of column length
516 (if (> nfiles (* collen ncols)) (setq collen (1+ collen)))
517 ;; Output the file names in columns, sorted vertically:
518 (let ((i 0) j)
519 (while (< i collen)
520 (setq j i)
521 (while (< j nfiles)
522 (insert (format fmt (nth j files)))
523 (setq j (+ j collen)))
524 ;; FJW: This is completely unnecessary, but I don't like
525 ;; trailing white space...
526 (delete-region (point) (progn (skip-chars-backward " \t") (point)))
527 (insert ?\n)
528 (setq i (1+ i))))))
530 (defun ls-lisp-delete-matching (regexp list)
531 "Delete all elements matching REGEXP from LIST, return new list."
532 ;; Should perhaps use setcdr for efficiency.
533 (let (result)
534 (while list
535 (or (string-match regexp (caar list))
536 (setq result (cons (car list) result)))
537 (setq list (cdr list)))
538 result))
540 (defsubst ls-lisp-string-lessp (s1 s2)
541 "Return t if string S1 should sort before string S2.
542 Case is significant if `ls-lisp-ignore-case' is nil.
543 Uses `string-collate-lessp' if `ls-lisp-use-string-collate' is non-nil,
544 `compare-strings' otherwise.
545 On GNU/Linux systems, if the locale specifies UTF-8 as the codeset,
546 the sorting order will place together file names that differ only
547 by punctuation characters, like `.emacs' and `emacs'. To have a
548 similar behavior on MS-Windows, customize `ls-lisp-UCA-like-collation'
549 to a non-nil value."
550 (let ((w32-collate-ignore-punctuation ls-lisp-UCA-like-collation))
551 (if ls-lisp-use-string-collate
552 (string-collate-lessp s1 s2 nil ls-lisp-ignore-case)
553 (let ((u (compare-strings s1 0 nil s2 0 nil ls-lisp-ignore-case)))
554 (and (numberp u) (< u 0))))))
556 (defun ls-lisp-version-lessp (s1 s2)
557 "Return t if versioned string S1 should sort before versioned string S2.
559 Case is significant if `ls-lisp-ignore-case' is nil.
560 This is the same as string-lessp (with the exception of case
561 insensitivity), but sequences of digits are compared numerically,
562 as a whole, in the same manner as the `strverscmp' function available
563 in some standard C libraries does."
564 (let ((i1 0)
565 (i2 0)
566 (len1 (length s1))
567 (len2 (length s2))
568 (val 0)
569 ni1 ni2 e1 e2 found-2-numbers-p)
570 (while (and (< i1 len1) (< i2 len2) (zerop val))
571 (unless found-2-numbers-p
572 (setq ni1 (string-match "[0-9]+" s1 i1)
573 e1 (match-end 0))
574 (setq ni2 (string-match "[0-9]+" s2 i2)
575 e2 (match-end 0)))
576 (cond
577 ((and ni1 ni2)
578 (cond
579 ((and (> ni1 i1) (> ni2 i2))
580 ;; Compare non-numerical part as strings.
581 (setq val (compare-strings s1 i1 ni1 s2 i2 ni2 ls-lisp-ignore-case)
582 i1 ni1
583 i2 ni2
584 found-2-numbers-p t))
585 ((and (= ni1 i1) (= ni2 i2))
586 (setq found-2-numbers-p nil)
587 ;; Compare numerical parts as integral and/or fractional parts.
588 (let* ((sub1 (substring s1 ni1 e1))
589 (sub2 (substring s2 ni2 e2))
590 ;; "Fraction" is a numerical sequence with leading zeros.
591 (fr1 (string-match "\\`0+" sub1))
592 (fr2 (string-match "\\`0+" sub2)))
593 (cond
594 ((and fr1 fr2) ; two fractions, the shortest wins
595 (setq val (- val (- (length sub1) (length sub2)))))
596 (fr1 ; a fraction is always less than an integral
597 (setq val (- ni1)))
598 (fr2
599 (setq val ni2)))
600 (if (zerop val) ; fall back on numerical comparison
601 (setq val (- (string-to-number sub1)
602 (string-to-number sub2))))
603 (setq i1 e1
604 i2 e2)))
606 (setq val (compare-strings s1 i1 nil s2 i2 nil ls-lisp-ignore-case)
607 i1 len1
608 i2 len2))))
609 (t (setq val (compare-strings s1 i1 nil s2 i2 nil ls-lisp-ignore-case)
610 i1 len1
611 i2 len2)))
612 (and (eq val t) (setq val 0)))
613 (if (zerop val)
614 (setq val (- len1 len2)))
615 (< val 0)))
617 (defun ls-lisp-handle-switches (file-alist switches)
618 "Return new FILE-ALIST sorted according to SWITCHES.
619 SWITCHES is a list of characters. Default sorting is alphabetic."
620 ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
621 (or (memq ?U switches) ; unsorted
622 ;; Catch and ignore unexpected sorting errors
623 (condition-case err
624 (setq file-alist
625 (let (index)
626 ;; Copy file-alist in case of error
627 (sort (copy-sequence file-alist) ; modifies its argument!
628 (cond ((memq ?S switches)
629 (lambda (x y) ; sorted on size
630 ;; 7th file attribute is file size
631 ;; Make largest file come first
632 (< (nth 7 (cdr y))
633 (nth 7 (cdr x)))))
634 ((setq index (ls-lisp-time-index switches))
635 (lambda (x y) ; sorted on time
636 (time-less-p (nth index (cdr y))
637 (nth index (cdr x)))))
638 ((memq ?X switches)
639 (lambda (x y) ; sorted on extension
640 (ls-lisp-string-lessp
641 (ls-lisp-extension (car x))
642 (ls-lisp-extension (car y)))))
643 ((memq ?v switches)
644 (lambda (x y) ; sorted by version number
645 (ls-lisp-version-lessp (car x) (car y))))
647 (lambda (x y) ; sorted alphabetically
648 (ls-lisp-string-lessp (car x) (car y))))))))
649 (error (message "Unsorted (ls-lisp sorting error) - %s"
650 (error-message-string err))
651 (ding) (sit-for 2)))) ; to show user the message!
652 (if (memq ?F switches) ; classify switch
653 (setq file-alist (mapcar 'ls-lisp-classify file-alist)))
654 (if ls-lisp-dirs-first
655 ;; Re-sort directories first, without otherwise changing the
656 ;; ordering, and reverse whole list. cadr of each element of
657 ;; `file-alist' is t for directory, string (name linked to) for
658 ;; symbolic link, or nil.
659 (let (el dirs files)
660 (while file-alist
661 (if (or (eq (cadr (setq el (car file-alist))) t) ; directory
662 (and (stringp (cadr el))
663 (file-directory-p (cadr el)))) ; symlink to a directory
664 (setq dirs (cons el dirs))
665 (setq files (cons el files)))
666 (setq file-alist (cdr file-alist)))
667 (setq file-alist
668 (if (memq ?U switches) ; unsorted order is reversed
669 (nconc dirs files)
670 (nconc files dirs)
671 ))))
672 ;; Finally reverse file alist if necessary.
673 ;; (eq below MUST compare `(not (memq ...))' to force comparison of
674 ;; t or nil, rather than list tails!)
675 (if (eq (eq (not (memq ?U switches)) ; unsorted order is reversed
676 (not (memq ?r switches))) ; reversed sort order requested
677 ls-lisp-dirs-first) ; already reversed
678 (nreverse file-alist)
679 file-alist))
681 (defun ls-lisp-classify-file (filename fattr)
682 "Append a character to FILENAME indicating the file type.
684 FATTR is the file attributes returned by `file-attributes' for the file.
685 The file type indicators are `/' for directories, `@' for symbolic
686 links, `|' for FIFOs, `=' for sockets, `*' for regular files that
687 are executable, and nothing for other types of files."
688 (let* ((type (car fattr))
689 (modestr (nth 8 fattr))
690 (typestr (substring modestr 0 1)))
691 (cond
692 (type
693 (concat filename (if (eq type t) "/" "@")))
694 ((string-match "x" modestr)
695 (concat filename "*"))
696 ((string= "p" typestr)
697 (concat filename "|"))
698 ((string= "s" typestr)
699 (concat filename "="))
700 (t filename))))
702 (defun ls-lisp-classify (filedata)
703 "Append a character to file name in FILEDATA indicating the file type.
705 FILEDATA has the form (FILENAME . ATTRIBUTES), where ATTRIBUTES is the
706 structure returned by `file-attributes' for that file.
708 The file type indicators are `/' for directories, `@' for symbolic
709 links, `|' for FIFOs, `=' for sockets, `*' for regular files that
710 are executable, and nothing for other types of files."
711 (let ((file-name (car filedata))
712 (fattr (cdr filedata)))
713 (setq file-name (propertize file-name 'dired-filename t))
714 (cons (ls-lisp-classify-file file-name fattr) fattr)))
716 (defun ls-lisp-extension (filename)
717 "Return extension of FILENAME (ignoring any version extension)
718 FOLLOWED by null and full filename, SOLELY for full alpha sort."
719 ;; Force extension sort order: `no ext' then `null ext' then `ext'
720 ;; to agree with GNU ls.
721 (concat
722 (let* ((i (length filename)) end)
723 (if (= (aref filename (1- i)) ?.) ; null extension
724 "\0"
725 (while (and (>= (setq i (1- i)) 0)
726 (/= (aref filename i) ?.)))
727 (if (< i 0) "\0\0" ; no extension
728 (if (/= (aref filename (1+ i)) ?~)
729 (substring filename (1+ i))
730 ;; version extension found -- ignore it
731 (setq end i)
732 (while (and (>= (setq i (1- i)) 0)
733 (/= (aref filename i) ?.)))
734 (if (< i 0) "\0\0" ; no extension
735 (substring filename (1+ i) end))))
736 )) "\0" filename))
738 (defun ls-lisp-format (file-name file-attr file-size switches time-index)
739 "Format one line of long ls output for file FILE-NAME.
740 FILE-ATTR and FILE-SIZE give the file's attributes and size.
741 SWITCHES and TIME-INDEX give the full switch list and time data."
742 (let ((file-type (nth 0 file-attr))
743 ;; t for directory, string (name linked to)
744 ;; for symbolic link, or nil.
745 (drwxrwxrwx (nth 8 file-attr))) ; attribute string ("drwxrwxrwx")
746 (concat (if (memq ?i switches) ; inode number
747 (let ((inode (nth 10 file-attr)))
748 (if (consp inode)
749 (if (consp (cdr inode))
750 ;; 2^(24+16) = 1099511627776.0, but
751 ;; multiplying by it and then adding the
752 ;; other members of the cons cell in one go
753 ;; loses precision, since a double does not
754 ;; have enough significant digits to hold a
755 ;; full 64-bit value. So below we split
756 ;; 1099511627776 into high 13 and low 5
757 ;; digits and compute in two parts.
758 (let ((p1 (* (car inode) 10995116.0))
759 (p2 (+ (* (car inode) 27776.0)
760 (* (cadr inode) 65536.0)
761 (cddr inode))))
762 (format " %13.0f%05.0f "
763 ;; Use floor to emulate integer
764 ;; division.
765 (+ p1 (floor p2 100000.0))
766 (mod p2 100000.0)))
767 (format " %18.0f "
768 (+ (* (car inode) 65536.0)
769 (cdr inode))))
770 (format " %18d " inode))))
771 ;; nil is treated like "" in concat
772 (if (memq ?s switches) ; size in K, rounded up
773 ;; In GNU ls, -h affects the size in blocks, displayed
774 ;; by -s, as well.
775 (if (memq ?h switches)
776 (format "%6s "
777 (file-size-human-readable
778 ;; We use 1K as "block size", although
779 ;; most Windows volumes use 4KB to 8KB
780 ;; clusters, and exFAT will usually have
781 ;; clusters of 32KB or even 128KB. See
782 ;; KB article 140365 for the details.
783 (* 1024.0 (fceiling (/ file-size 1024.0)))))
784 (format ls-lisp-filesize-b-fmt
785 (fceiling (/ file-size 1024.0)))))
786 drwxrwxrwx ; attribute string
787 (if (memq 'links ls-lisp-verbosity)
788 (format "%3d" (nth 1 file-attr))) ; link count
789 ;; Numeric uid/gid are more confusing than helpful;
790 ;; Emacs should be able to make strings of them.
791 ;; They tend to be bogus on non-UNIX platforms anyway so
792 ;; optionally hide them.
793 (if (memq 'uid ls-lisp-verbosity)
794 ;; uid can be a string or an integer
795 (let ((uid (nth 2 file-attr)))
796 (format (if (stringp uid)
797 ls-lisp-uid-s-fmt
798 ls-lisp-uid-d-fmt)
799 uid)))
800 (if (not (memq ?G switches)) ; GNU ls -- shows group by default
801 (if (or (memq ?g switches) ; UNIX ls -- no group by default
802 (memq 'gid ls-lisp-verbosity))
803 (let ((gid (nth 3 file-attr)))
804 (format (if (stringp gid)
805 ls-lisp-gid-s-fmt
806 ls-lisp-gid-d-fmt)
807 gid))))
808 (ls-lisp-format-file-size file-size (memq ?h switches))
810 (ls-lisp-format-time file-attr time-index)
812 (if (not (memq ?F switches)) ; ls-lisp-classify already did that
813 (propertize file-name 'dired-filename t)
814 file-name)
815 (if (stringp file-type) ; is a symbolic link
816 (concat " -> " file-type))
817 "\n"
820 (defun ls-lisp-time-index (switches)
821 "Return time index into file-attributes according to ls SWITCHES list.
822 Return nil if no time switch found."
823 ;; FJW: Default of nil is IMPORTANT and used in `ls-lisp-handle-switches'!
824 (cond ((memq ?c switches) 6) ; last mode change
825 ((memq ?t switches) 5) ; last modtime
826 ((memq ?u switches) 4))) ; last access
828 (defun ls-lisp-format-time (file-attr time-index)
829 "Format time for file with attributes FILE-ATTR according to TIME-INDEX.
830 Use the same method as ls to decide whether to show time-of-day or year,
831 depending on distance between file date and the current time.
832 All ls time options, namely c, t and u, are handled."
833 (let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime
834 (diff (- (float-time time) (float-time)))
835 ;; Consider a time to be recent if it is within the past six
836 ;; months. A Gregorian year has 365.2425 * 24 * 60 * 60 ==
837 ;; 31556952 seconds on the average, and half of that is 15778476.
838 ;; Write the constant explicitly to avoid roundoff error.
839 (past-cutoff -15778476)) ; half a Gregorian year
840 (condition-case nil
841 ;; Use traditional time format in the C or POSIX locale,
842 ;; ISO-style time format otherwise, so columns line up.
843 (let ((locale system-time-locale))
844 (if (not locale)
845 (let ((vars '("LC_ALL" "LC_TIME" "LANG")))
846 (while (and vars (not (setq locale (getenv (car vars)))))
847 (setq vars (cdr vars)))))
848 (if (member locale '("C" "POSIX"))
849 (setq locale nil))
850 (format-time-string
851 (if (and (<= past-cutoff diff) (<= diff 0))
852 (if (and locale (not ls-lisp-use-localized-time-format))
853 "%m-%d %H:%M"
854 (nth 0 ls-lisp-format-time-list))
855 (if (and locale (not ls-lisp-use-localized-time-format))
856 "%Y-%m-%d "
857 (nth 1 ls-lisp-format-time-list)))
858 time))
859 (error "Unk 0 0000"))))
861 (defun ls-lisp-format-file-size (file-size human-readable)
862 (if (not human-readable)
863 (format (if (floatp file-size)
864 ls-lisp-filesize-f-fmt
865 ls-lisp-filesize-d-fmt)
866 file-size)
867 (format " %6s" (file-size-human-readable file-size))))
869 (provide 'ls-lisp)
871 ;;; ls-lisp.el ends here