1 ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp -*- lexical-binding: t -*-
3 ;; Copyright (C) 1992, 1994, 2000-2018 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
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 <https://www.gnu.org/licenses/>.
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
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
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
66 "Emulate the ls program completely in Emacs Lisp."
70 (defun ls-lisp-set-options ()
71 "Reset the ls-lisp options that depend on `ls-lisp-emulation'."
72 (mapc 'custom-reevaluate-setting
73 '(ls-lisp-ignore-case ls-lisp-dirs-first ls-lisp-verbosity
)))
75 (defcustom ls-lisp-emulation
76 (cond ;; ((eq system-type 'windows-nt) 'MS-Windows)
77 ((memq system-type
'(hpux usg-unix-v berkeley-unix
))
78 'UNIX
)) ; very similar to GNU
79 ;; Anything else defaults to nil, meaning GNU.
80 "Platform to emulate: GNU (default), macOS, MS-Windows, UNIX.
81 Corresponding value is one of: nil, `MacOS', `MS-Windows', `UNIX'.
82 Set this to your preferred value; it need not match the actual platform
85 This variable does not affect the behavior of ls-lisp directly.
86 Rather, it controls the default values for some variables that do:
87 `ls-lisp-ignore-case', `ls-lisp-dirs-first', and `ls-lisp-verbosity'.
89 If you change this variable directly (without using customize)
90 after loading `ls-lisp', you should use `ls-lisp-set-options' to
91 update the dependent variables."
92 :type
'(choice (const :tag
"GNU" nil
)
96 :initialize
'custom-initialize-default
97 :set
(lambda (symbol value
)
98 (unless (equal value
(eval symbol
))
99 (custom-set-default symbol value
)
100 (ls-lisp-set-options)))
103 ;; Only made an obsolete alias in 23.3. Before that, the initial
104 ;; value was set according to:
105 ;; (or (memq ls-lisp-emulation '(MS-Windows MacOS))
106 ;; (and (boundp 'ls-lisp-dired-ignore-case) ls-lisp-dired-ignore-case))
107 ;; Which isn't the right thing to do.
108 (define-obsolete-variable-alias 'ls-lisp-dired-ignore-case
109 'ls-lisp-ignore-case
"21.1")
111 (defcustom ls-lisp-ignore-case
112 (memq ls-lisp-emulation
'(MS-Windows MacOS
))
113 "Non-nil causes ls-lisp alphabetic sorting to ignore case."
114 :set-after
'(ls-lisp-emulation)
118 (defcustom ls-lisp-use-string-collate
119 (cond ((memq ls-lisp-emulation
'(MacOS UNIX
)) nil
)
120 (t t
)) ; GNU/Linux or MS-Windows emulate GNU ls
121 "Non-nil causes ls-lisp to sort files in locale-dependent collation order.
123 A value of nil means use ordinary string comparison (see `compare-strings')
124 for sorting files. A non-nil value uses `string-collate-lessp' instead,
125 which more closely emulates what GNU `ls' does.
127 On GNU/Linux systems, if the locale's codeset specifies UTF-8, as
128 in \"en_US.UTF-8\", the collation order follows the Unicode
129 Collation Algorithm (UCA), which places together file names that
130 differ only in punctuation characters. On MS-Windows, customize
131 the option `ls-lisp-UCA-like-collation' to a non-nil value to get
134 :set-after
'(ls-lisp-emulation)
138 (defcustom ls-lisp-UCA-like-collation t
139 "Non-nil means force ls-lisp use a collation order compatible with UCA.
141 UCA is the Unicode Collation Algorithm. GNU/Linux systems automatically
142 follow it in their string-collation routines if the locale specifies
143 UTF-8 as its codeset. On MS-Windows, customize this option to a non-nil
144 value to get similar behavior.
146 When this option is non-nil, and `ls-lisp-use-string-collate' is also
147 non-nil, the collation order produced on MS-Windows will ignore
148 punctuation and symbol characters, which will, for example, place
149 `.foo' near `foo'. See the documentation of `string-collate-lessp'
150 and `w32-collate-ignore-punctuation' for more details.
152 This option is ignored on platforms other than MS-Windows; to
153 control the collation ordering of the file names on those other
154 systems, set your locale instead."
159 (defcustom ls-lisp-dirs-first
(eq ls-lisp-emulation
'MS-Windows
)
160 "Non-nil causes ls-lisp to sort directories first in any ordering.
161 \(Or last if it is reversed.) Follows Microsoft Windows Explorer."
162 ;; Functionality suggested by Chris McMahan <cmcmahan@one.net>
163 :set-after
'(ls-lisp-emulation)
167 (defcustom ls-lisp-verbosity
168 (cond ((eq ls-lisp-emulation
'MacOS
) nil
)
169 ((eq ls-lisp-emulation
'MS-Windows
)
170 (if (and (fboundp 'w32-using-nt
) (w32-using-nt))
171 '(links))) ; distinguish NT/2K from 9x
172 ((eq ls-lisp-emulation
'UNIX
) '(links uid
)) ; UNIX ls
173 (t '(links uid gid
))) ; GNU ls
174 "A list of optional file attributes that ls-lisp should display.
175 It should contain none or more of the symbols: links, uid, gid.
176 A value of nil (or an empty list) means display none of them.
178 Concepts come from UNIX: `links' means count of names associated with
179 the file; `uid' means user (owner) identifier; `gid' means group
182 If emulation is MacOS then default is nil;
183 if emulation is MS-Windows then default is `(links)' if platform is
184 Windows NT/2K, nil otherwise;
185 if emulation is UNIX then default is `(links uid)';
186 if emulation is GNU then default is `(links uid gid)'."
187 :set-after
'(ls-lisp-emulation)
188 ;; Functionality suggested by Howard Melman <howard@silverstream.com>
189 :type
'(set (const :tag
"Show Link Count" links
)
190 (const :tag
"Show User" uid
)
191 (const :tag
"Show Group" gid
))
194 (defcustom ls-lisp-use-insert-directory-program
195 (not (memq system-type
'(ms-dos windows-nt
)))
196 "Non-nil causes ls-lisp to revert back to using `insert-directory-program'.
197 This is useful on platforms where ls-lisp is dumped into Emacs, such as
198 Microsoft Windows, but you would still like to use a program to list
199 the contents of a directory."
203 ;;; Autoloaded because it is let-bound in `recover-session', `mail-recover-1'.
205 (defcustom ls-lisp-support-shell-wildcards t
206 "Non-nil means ls-lisp treats file patterns as shell wildcards.
207 Otherwise they are treated as Emacs regexps (for backward compatibility)."
211 (defcustom ls-lisp-format-time-list
214 "List of `format-time-string' specs to display file time stamps.
215 These specs are used ONLY if a valid locale can not be determined.
217 If `ls-lisp-use-localized-time-format' is non-nil, these specs are used
218 regardless of whether the locale can be determined.
220 Syntax: (EARLY-TIME-FORMAT OLD-TIME-FORMAT)
222 The EARLY-TIME-FORMAT is used if file has been modified within the
223 current year. The OLD-TIME-FORMAT is used for older files. To use ISO
224 8601 dates, you could set:
226 \(setq ls-lisp-format-time-list
227 \\='(\"%Y-%m-%d %H:%M\"
229 :type
'(list (string :tag
"Early time format")
230 (string :tag
"Old time format"))
233 (defcustom ls-lisp-use-localized-time-format nil
234 "Non-nil means to always use `ls-lisp-format-time-list' for time stamps.
235 This applies even if a valid locale is specified.
237 WARNING: Using localized date/time format might cause Dired columns
238 to fail to line up, e.g. if month names are not all of the same length."
242 (defvar ls-lisp-uid-d-fmt
" %d"
243 "Format to display integer UIDs.")
244 (defvar ls-lisp-uid-s-fmt
" %s"
245 "Format to display user names.")
246 (defvar ls-lisp-gid-d-fmt
" %d"
247 "Format to display integer GIDs.")
248 (defvar ls-lisp-gid-s-fmt
" %s"
249 "Format to display user group names.")
250 (defvar ls-lisp-filesize-d-fmt
" %d"
251 "Format to display integer file sizes.")
252 (defvar ls-lisp-filesize-f-fmt
" %.0f"
253 "Format to display float file sizes.")
254 (defvar ls-lisp-filesize-b-fmt
" %.0f"
255 "Format to display file sizes in blocks (for the -s switch).")
257 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
259 (defun ls-lisp--insert-directory (orig-fun file switches
&optional wildcard full-directory-p
)
260 "Insert directory listing for FILE, formatted according to SWITCHES.
261 Leaves point after the inserted text.
262 SWITCHES may be a string of options, or a list of strings.
263 Optional third arg WILDCARD means treat FILE as shell wildcard.
264 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
265 switches do not contain `d', so that a full listing is expected.
267 This version of the function comes from `ls-lisp.el'.
268 If the value of `ls-lisp-use-insert-directory-program' is non-nil then
269 this advice just delegates the work to ORIG-FUN (the normal `insert-directory'
270 function from `files.el').
271 But if the value of `ls-lisp-use-insert-directory-program' is nil
272 then it runs a Lisp emulation.
274 The Lisp emulation does not run any external programs or shells. It
275 supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards'
276 is non-nil; otherwise, it interprets wildcards as regular expressions
277 to match file names. It does not support all `ls' switches -- those
278 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
279 is assumed to be always present and cannot be turned off."
280 (if ls-lisp-use-insert-directory-program
282 file switches wildcard full-directory-p
)
283 ;; We need the directory in order to find the right handler.
284 (let ((handler (find-file-name-handler (expand-file-name file
)
289 (funcall handler
'insert-directory file switches
290 wildcard full-directory-p
)
291 ;; Remove --dired switch
292 (if (string-match "--dired " switches
)
293 (setq switches
(replace-match "" nil nil switches
)))
294 ;; Convert SWITCHES to a list of characters.
295 (setq switches
(delete ?\
(delete ?-
(append switches nil
))))
296 ;; Sometimes we get ".../foo*/" as FILE. While the shell and
297 ;; `ls' don't mind, we certainly do, because it makes us think
298 ;; there is no wildcard, only a directory name.
299 (if (and ls-lisp-support-shell-wildcards
300 (string-match "[[?*]" file
)
301 ;; Prefer an existing file to wildcards, like
302 ;; dired-noselect does.
303 (not (file-exists-p file
)))
305 (or (not (eq (aref file
(1- (length file
))) ?
/))
306 (setq file
(substring file
0 (1- (length file
)))))
309 (setq wildcard-regexp
310 (if ls-lisp-support-shell-wildcards
311 (wildcard-to-regexp (file-name-nondirectory file
))
312 (file-name-nondirectory file
))
313 file
(file-name-directory file
))
314 (if (memq ?B switches
) (setq wildcard-regexp
"[^~]\\'")))
316 (ls-lisp-insert-directory
317 file switches
(ls-lisp-time-index switches
)
318 wildcard-regexp full-directory-p
)
320 ;; Maybe they wanted a literal file that just happens to
321 ;; use characters special to shell wildcards.
322 (if (equal (cadr err
) "Unmatched [ or [^")
324 (setq wildcard-regexp
(if (memq ?B switches
) "[^~]\\'")
325 file
(file-relative-name orig-file
))
326 (ls-lisp-insert-directory
327 file switches
(ls-lisp-time-index switches
)
328 nil full-directory-p
))
329 (signal (car err
) (cdr err
)))))
330 ;; Try to insert the amount of free space.
332 (goto-char (point-min))
333 ;; First find the line to put it on.
334 (when (re-search-forward "^total" nil t
)
335 (let ((available (get-free-disk-space ".")))
337 ;; Replace "total" with "total used", to avoid confusion.
338 (replace-match "total used in directory")
340 (insert " available " available
)))))))))
341 (advice-add 'insert-directory
:around
#'ls-lisp--insert-directory
)
343 (defun ls-lisp-insert-directory
344 (file switches time-index wildcard-regexp full-directory-p
)
345 "Insert directory listing for FILE, formatted according to SWITCHES.
346 Leaves point after the inserted text. This is an internal function
347 optionally called by the `ls-lisp.el' version of `insert-directory'.
348 It is called recursively if the -R switch is used.
349 SWITCHES is a *list* of characters. TIME-INDEX is the time index into
350 file-attributes according to SWITCHES. WILDCARD-REGEXP is nil or an *Emacs
351 regexp*. FULL-DIRECTORY-P means file is a directory and SWITCHES does
352 not contain `d', so that a full listing is expected."
353 (if (or (and wildcard-regexp
354 (not (string= "[^~]\\'" wildcard-regexp
))) ; Switch -B pseudo-wildcard regexp
356 (let* ((dir (file-name-as-directory file
))
357 (default-directory dir
) ; so that file-attributes works
359 (directory-files-and-attributes dir nil wildcard-regexp t
360 (if (memq ?n switches
)
367 ;; do all bindings here for speed
368 total-line files elt short file-size attr
369 fuid fgid uid-len gid-len
)
370 (setq file-alist
(ls-lisp-sanitize file-alist
))
371 (cond ((memq ?A switches
)
373 (ls-lisp-delete-matching "^\\.\\.?$" file-alist
)))
374 ((not (memq ?a switches
))
375 ;; if neither -A nor -a, flush . files
377 (ls-lisp-delete-matching "^\\." file-alist
))))
379 (ls-lisp-handle-switches file-alist switches
))
380 (if (memq ?C switches
) ; column (-C) format
381 (ls-lisp-column-format file-alist
)
382 (setq total-line
(cons (point) (car-safe file-alist
)))
383 ;; Find the appropriate format for displaying uid, gid, and
384 ;; file size, by finding the longest strings among all the
385 ;; files we are about to display.
386 (dolist (elt file-alist
)
388 fuid
(file-attribute-user-id attr
)
389 uid-len
(if (stringp fuid
) (string-width fuid
)
390 (length (format "%d" fuid
)))
391 fgid
(file-attribute-group-id attr
)
392 gid-len
(if (stringp fgid
) (string-width fgid
)
393 (length (format "%d" fgid
)))
394 file-size
(file-attribute-size attr
))
395 (if (> uid-len max-uid-len
)
396 (setq max-uid-len uid-len
))
397 (if (> gid-len max-gid-len
)
398 (setq max-gid-len gid-len
))
399 (if (> file-size max-file-size
)
400 (setq max-file-size file-size
)))
401 (setq ls-lisp-uid-d-fmt
(format " %%-%dd" max-uid-len
))
402 (setq ls-lisp-uid-s-fmt
(format " %%-%ds" max-uid-len
))
403 (setq ls-lisp-gid-d-fmt
(format " %%-%dd" max-gid-len
))
404 (setq ls-lisp-gid-s-fmt
(format " %%-%ds" max-gid-len
))
405 (setq ls-lisp-filesize-d-fmt
406 (format " %%%dd" (length (format "%.0f" max-file-size
))))
407 (setq ls-lisp-filesize-f-fmt
408 (format " %%%d.0f" (length (format "%.0f" max-file-size
))))
409 (if (memq ?s switches
)
410 (setq ls-lisp-filesize-b-fmt
412 (length (format "%.0f"
414 (/ max-file-size
1024.0)))))))
415 (setq files file-alist
)
416 (while files
; long (-l) format
417 (setq elt
(car files
)
421 file-size
(file-attribute-size attr
))
423 (setq sum
(+ file-size
424 ;; Even if neither SUM nor file's size
425 ;; overflow, their sum could.
426 (if (or (< sum
(- 134217727 file-size
))
431 (insert (ls-lisp-format short attr file-size
432 switches time-index
))))
433 ;; Insert total size of all files:
435 (goto-char (car total-line
))
437 ;; Shell says ``No match'' if no files match
438 ;; the wildcard; let's say something similar.
439 (insert "(No match)\n"))
440 (insert (format "total %.0f\n" (fceiling (/ sum
1024.0))))))
441 ;; dired-insert-directory expects to find point after the
442 ;; text. But if the listing is empty, as e.g. in empty
443 ;; directories with -a removed from switches, point will be
444 ;; before the inserted text, and dired-insert-directory will
445 ;; not indent the listing correctly. Going to the end of the
446 ;; buffer fixes that.
447 (unless files
(goto-char (point-max)))
448 (if (memq ?R switches
)
449 ;; List the contents of all directories recursively.
450 ;; cadr of each element of `file-alist' is t for
451 ;; directory, string (name linked to) for symbolic
454 (setq elt
(car file-alist
)
455 file-alist
(cdr file-alist
))
456 (when (and (eq (cadr elt
) t
) ; directory
457 ;; Under -F, we have already decorated all
458 ;; directories, including "." and "..", with
459 ;; a /, so allow for that as well.
460 (not (string-match "\\`\\.\\.?/?\\'" (car elt
))))
461 (setq elt
(expand-file-name (car elt
) dir
))
462 (insert "\n" elt
":\n")
463 (ls-lisp-insert-directory
464 elt switches time-index wildcard-regexp full-directory-p
)))))
465 ;; If not full-directory-p, FILE *must not* end in /, as
466 ;; file-attributes will not recognize a symlink to a directory,
467 ;; so must make it a relative filename as ls does:
468 (if (file-name-absolute-p file
) (setq file
(expand-file-name file
)))
469 (if (eq (aref file
(1- (length file
))) ?
/)
470 (setq file
(substring file
0 -
1)))
471 (let ((fattr (file-attributes file
'string
)))
473 (insert (ls-lisp-format
474 (if (memq ?F switches
)
475 (ls-lisp-classify-file file fattr
)
477 fattr
(file-attribute-size fattr
)
478 switches time-index
))
479 (message "%s: doesn't exist or is inaccessible" file
)
480 (ding) (sit-for 2))))) ; to show user the message!
482 (declare-function dired-read-dir-and-switches
"dired" (str))
483 (declare-function dired-goto-next-file
"dired" ())
485 (defun ls-lisp--dired (orig-fun dir-or-list
&optional switches
)
486 (interactive (dired-read-dir-and-switches ""))
487 (if (consp dir-or-list
)
488 (funcall orig-fun dir-or-list switches
)
489 (let ((dir-wildcard (insert-directory-wildcard-in-dir-p
490 (expand-file-name dir-or-list
))))
491 (if (not dir-wildcard
)
492 (funcall orig-fun dir-or-list switches
)
493 (let* ((default-directory (car dir-wildcard
))
494 (files (file-expand-wildcards (cdr dir-wildcard
)))
495 (dir (car dir-wildcard
)))
497 (let ((inhibit-read-only t
)
499 (apply orig-fun
(nconc (list dir
) files
) (and switches
(list switches
)))))
500 (with-current-buffer buf
502 (goto-char (point-min))
503 (dired-goto-next-file)
505 (insert " wildcard " (cdr dir-wildcard
) "\n"))))
506 (user-error "No files matching regexp")))))))
508 (advice-add 'dired
:around
#'ls-lisp--dired
)
510 (defun ls-lisp-sanitize (file-alist)
511 "Sanitize the elements in FILE-ALIST.
512 Fixes any elements in the alist for directory entries whose file
513 attributes are nil (meaning that `file-attributes' failed for
514 them). This is known to happen for some network shares, in
515 particular for the \"..\" directory entry.
517 If the \"..\" directory entry has nil attributes, the attributes
518 are copied from the \".\" entry, if they are non-nil. Otherwise,
519 the offending element is removed from the list, as are any
520 elements for other directory entries with nil attributes."
521 (if (and (null (cdr (assoc ".." file-alist
)))
522 (cdr (assoc "." file-alist
)))
523 (setcdr (assoc ".." file-alist
) (cdr (assoc "." file-alist
))))
524 (rassq-delete-all nil file-alist
))
526 (defun ls-lisp-column-format (file-alist)
527 "Insert the file names (only) in FILE-ALIST into the current buffer.
528 Format in columns, sorted vertically, following GNU ls -C.
529 Responds to the window width as ls should but may not!"
530 (let (files fmt ncols collen
(nfiles 0) (colwid 0))
531 ;; Count number of files as `nfiles', build list of filenames as
532 ;; `files', and find maximum filename length as `colwid':
535 (setq nfiles
(1+ nfiles
)
536 file
(caar file-alist
)
537 files
(cons file files
)
538 file-alist
(cdr file-alist
)
540 (if (> len colwid
) (setq colwid len
))))
541 (setq files
(nreverse files
)
542 colwid
(+ 2 colwid
) ; 2 character column gap
543 fmt
(format "%%-%ds" colwid
) ; print format
544 ncols
(/ (window-width) colwid
) ; no of columns
545 collen
(/ nfiles ncols
)) ; floor of column length
546 (if (> nfiles
(* collen ncols
)) (setq collen
(1+ collen
)))
547 ;; Output the file names in columns, sorted vertically:
552 (insert (format fmt
(nth j files
)))
553 (setq j
(+ j collen
)))
554 ;; FJW: This is completely unnecessary, but I don't like
555 ;; trailing white space...
556 (delete-region (point) (progn (skip-chars-backward " \t") (point)))
560 (defun ls-lisp-delete-matching (regexp list
)
561 "Delete all elements matching REGEXP from LIST, return new list."
562 ;; Should perhaps use setcdr for efficiency.
565 (or (string-match regexp
(caar list
))
566 (setq result
(cons (car list
) result
)))
567 (setq list
(cdr list
)))
570 (defvar w32-collate-ignore-punctuation
) ; Declare for non-w32 builds.
572 (defsubst ls-lisp-string-lessp
(s1 s2
)
573 "Return t if string S1 should sort before string S2.
574 Case is significant if `ls-lisp-ignore-case' is nil.
575 Uses `string-collate-lessp' if `ls-lisp-use-string-collate' is non-nil,
576 `compare-strings' otherwise.
577 On GNU/Linux systems, if the locale specifies UTF-8 as the codeset,
578 the sorting order will place together file names that differ only
579 by punctuation characters, like `.emacs' and `emacs'. To have a
580 similar behavior on MS-Windows, customize `ls-lisp-UCA-like-collation'
582 (let ((w32-collate-ignore-punctuation ls-lisp-UCA-like-collation
))
583 (if ls-lisp-use-string-collate
584 (string-collate-lessp s1 s2 nil ls-lisp-ignore-case
)
585 (let ((u (compare-strings s1
0 nil s2
0 nil ls-lisp-ignore-case
)))
586 (and (numberp u
) (< u
0))))))
588 (defun ls-lisp-version-lessp (s1 s2
)
589 "Return t if versioned string S1 should sort before versioned string S2.
591 Case is significant if `ls-lisp-ignore-case' is nil.
592 This is the same as string-lessp (with the exception of case
593 insensitivity), but sequences of digits are compared numerically,
594 as a whole, in the same manner as the `strverscmp' function available
595 in some standard C libraries does."
601 ni1 ni2 e1 e2 found-2-numbers-p
)
602 (while (and (< i1 len1
) (< i2 len2
) (zerop val
))
603 (unless found-2-numbers-p
604 (setq ni1
(string-match "[0-9]+" s1 i1
)
606 (setq ni2
(string-match "[0-9]+" s2 i2
)
611 ((and (> ni1 i1
) (> ni2 i2
))
612 ;; Compare non-numerical part as strings.
613 (setq val
(compare-strings s1 i1 ni1 s2 i2 ni2 ls-lisp-ignore-case
)
616 found-2-numbers-p t
))
617 ((and (= ni1 i1
) (= ni2 i2
))
618 (setq found-2-numbers-p nil
)
619 ;; Compare numerical parts as integral and/or fractional parts.
620 (let* ((sub1 (substring s1 ni1 e1
))
621 (sub2 (substring s2 ni2 e2
))
622 ;; "Fraction" is a numerical sequence with leading zeros.
623 (fr1 (string-match "\\`0+" sub1
))
624 (fr2 (string-match "\\`0+" sub2
)))
626 ((and fr1 fr2
) ; two fractions, the shortest wins
627 (setq val
(- val
(- (length sub1
) (length sub2
)))))
628 (fr1 ; a fraction is always less than an integral
632 (if (zerop val
) ; fall back on numerical comparison
633 (setq val
(- (string-to-number sub1
)
634 (string-to-number sub2
))))
638 (setq val
(compare-strings s1 i1 nil s2 i2 nil ls-lisp-ignore-case
)
641 (t (setq val
(compare-strings s1 i1 nil s2 i2 nil ls-lisp-ignore-case
)
644 (and (eq val t
) (setq val
0)))
646 (setq val
(- len1 len2
)))
649 (defun ls-lisp-handle-switches (file-alist switches
)
650 "Return new FILE-ALIST sorted according to SWITCHES.
651 SWITCHES is a list of characters. Default sorting is alphabetic."
652 ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
653 (or (memq ?U switches
) ; unsorted
654 ;; Catch and ignore unexpected sorting errors
658 ;; Copy file-alist in case of error
659 (sort (copy-sequence file-alist
) ; modifies its argument!
660 (cond ((memq ?S switches
)
661 (lambda (x y
) ; sorted on size
662 ;; Make largest file come first
663 (< (file-attribute-size (cdr y
))
664 (file-attribute-size (cdr x
)))))
665 ((setq index
(ls-lisp-time-index switches
))
666 (lambda (x y
) ; sorted on time
667 (time-less-p (nth index
(cdr y
))
668 (nth index
(cdr x
)))))
670 (lambda (x y
) ; sorted on extension
671 (ls-lisp-string-lessp
672 (ls-lisp-extension (car x
))
673 (ls-lisp-extension (car y
)))))
675 (lambda (x y
) ; sorted by version number
676 (ls-lisp-version-lessp (car x
) (car y
))))
678 (lambda (x y
) ; sorted alphabetically
679 (ls-lisp-string-lessp (car x
) (car y
))))))))
680 (error (message "Unsorted (ls-lisp sorting error) - %s"
681 (error-message-string err
))
682 (ding) (sit-for 2)))) ; to show user the message!
683 (if (memq ?F switches
) ; classify switch
684 (setq file-alist
(mapcar 'ls-lisp-classify file-alist
)))
685 (if ls-lisp-dirs-first
686 ;; Re-sort directories first, without otherwise changing the
687 ;; ordering, and reverse whole list. cadr of each element of
688 ;; `file-alist' is t for directory, string (name linked to) for
689 ;; symbolic link, or nil.
692 (if (or (eq (cadr (setq el
(car file-alist
))) t
) ; directory
693 (and (stringp (cadr el
))
694 (file-directory-p (cadr el
)))) ; symlink to a directory
695 (setq dirs
(cons el dirs
))
696 (setq files
(cons el files
)))
697 (setq file-alist
(cdr file-alist
)))
699 (if (memq ?U switches
) ; unsorted order is reversed
703 ;; Finally reverse file alist if necessary.
704 ;; (eq below MUST compare `(not (memq ...))' to force comparison of
705 ;; t or nil, rather than list tails!)
706 (if (eq (eq (not (memq ?U switches
)) ; unsorted order is reversed
707 (not (memq ?r switches
))) ; reversed sort order requested
708 ls-lisp-dirs-first
) ; already reversed
709 (nreverse file-alist
)
712 (defun ls-lisp-classify-file (filename fattr
)
713 "Append a character to FILENAME indicating the file type.
715 This function puts the `dired-filename' property on FILENAME, but
716 not on the character indicator it appends.
717 FATTR is the file attributes returned by `file-attributes' for the file.
718 The file type indicators are `/' for directories, `@' for symbolic
719 links, `|' for FIFOs, `=' for sockets, `*' for regular files that
720 are executable, and nothing for other types of files."
721 (let* ((type (file-attribute-type fattr
))
722 (modestr (file-attribute-modes fattr
))
723 (typestr (substring modestr
0 1))
724 (file-name (propertize filename
'dired-filename t
)))
727 (concat file-name
(if (eq type t
) "/" "@")))
728 ((string-match "x" modestr
)
729 (concat file-name
"*"))
730 ((string= "p" typestr
)
731 (concat file-name
"|"))
732 ((string= "s" typestr
)
733 (concat file-name
"="))
736 (defun ls-lisp-classify (filedata)
737 "Append a character to file name in FILEDATA indicating the file type.
739 FILEDATA has the form (FILENAME . ATTRIBUTES), where ATTRIBUTES is the
740 structure returned by `file-attributes' for that file.
742 The file type indicators are `/' for directories, `@' for symbolic
743 links, `|' for FIFOs, `=' for sockets, `*' for regular files that
744 are executable, and nothing for other types of files."
745 (let ((file-name (car filedata
))
746 (fattr (cdr filedata
)))
747 (cons (ls-lisp-classify-file file-name fattr
) fattr
)))
749 (defun ls-lisp-extension (filename)
750 "Return extension of FILENAME (ignoring any version extension)
751 FOLLOWED by null and full filename, SOLELY for full alpha sort."
752 ;; Force extension sort order: `no ext' then `null ext' then `ext'
753 ;; to agree with GNU ls.
755 (let* ((i (length filename
)) end
)
756 (if (= (aref filename
(1- i
)) ?.
) ; null extension
758 (while (and (>= (setq i
(1- i
)) 0)
759 (/= (aref filename i
) ?.
)))
760 (if (< i
0) "\0\0" ; no extension
761 (if (/= (aref filename
(1+ i
)) ?~
)
762 (substring filename
(1+ i
))
763 ;; version extension found -- ignore it
765 (while (and (>= (setq i
(1- i
)) 0)
766 (/= (aref filename i
) ?.
)))
767 (if (< i
0) "\0\0" ; no extension
768 (substring filename
(1+ i
) end
))))
771 (defun ls-lisp-format (file-name file-attr file-size switches time-index
)
772 "Format one line of long ls output for file FILE-NAME.
773 FILE-ATTR and FILE-SIZE give the file's attributes and size.
774 SWITCHES and TIME-INDEX give the full switch list and time data."
775 (let ((file-type (file-attribute-type file-attr
))
776 ;; t for directory, string (name linked to)
777 ;; for symbolic link, or nil.
778 (drwxrwxrwx (file-attribute-modes file-attr
)))
779 (concat (if (memq ?i switches
) ; inode number
780 (let ((inode (file-attribute-inode-number file-attr
)))
781 (format " %18d " inode
)))
782 ;; nil is treated like "" in concat
783 (if (memq ?s switches
) ; size in K, rounded up
784 ;; In GNU ls, -h affects the size in blocks, displayed
786 (if (memq ?h switches
)
788 (file-size-human-readable
789 ;; We use 1K as "block size", although
790 ;; most Windows volumes use 4KB to 8KB
791 ;; clusters, and exFAT will usually have
792 ;; clusters of 32KB or even 128KB. See
793 ;; KB article 140365 for the details.
794 (* 1024.0 (fceiling (/ file-size
1024.0)))))
795 (format ls-lisp-filesize-b-fmt
796 (fceiling (/ file-size
1024.0)))))
797 drwxrwxrwx
; attribute string
798 (if (memq 'links ls-lisp-verbosity
)
799 (format "%3d" (file-attribute-link-number file-attr
)))
800 ;; Numeric uid/gid are more confusing than helpful;
801 ;; Emacs should be able to make strings of them.
802 ;; They tend to be bogus on non-UNIX platforms anyway so
803 ;; optionally hide them.
804 (if (memq 'uid ls-lisp-verbosity
)
805 ;; uid can be a string or an integer
806 (let ((uid (file-attribute-user-id file-attr
)))
807 (format (if (stringp uid
)
811 (if (not (memq ?G switches
)) ; GNU ls -- shows group by default
812 (if (or (memq ?g switches
) ; UNIX ls -- no group by default
813 (memq 'gid ls-lisp-verbosity
))
814 (let ((gid (file-attribute-group-id file-attr
)))
815 (format (if (stringp gid
)
819 (ls-lisp-format-file-size file-size
(memq ?h switches
))
821 (ls-lisp-format-time file-attr time-index
)
823 (if (not (memq ?F switches
)) ; ls-lisp-classify-file already did that
824 (propertize file-name
'dired-filename t
)
826 (if (stringp file-type
) ; is a symbolic link
827 (concat " -> " file-type
))
831 (defun ls-lisp-time-index (switches)
832 "Return time index into file-attributes according to ls SWITCHES list.
833 Return nil if no time switch found."
834 ;; FJW: Default of nil is IMPORTANT and used in `ls-lisp-handle-switches'!
835 (cond ((memq ?c switches
) 6) ; last mode change
836 ((memq ?t switches
) 5) ; last modtime
837 ((memq ?u switches
) 4))) ; last access
839 (defun ls-lisp-format-time (file-attr time-index
)
840 "Format time for file with attributes FILE-ATTR according to TIME-INDEX.
841 Use the same method as ls to decide whether to show time-of-day or year,
842 depending on distance between file date and the current time.
843 All ls time options, namely c, t and u, are handled."
844 (let* ((time (nth (or time-index
5) file-attr
)) ; default is last modtime
845 (diff (time-subtract time nil
))
846 ;; Consider a time to be recent if it is within the past six
847 ;; months. A Gregorian year has 365.2425 * 24 * 60 * 60 ==
848 ;; 31556952 seconds on the average, and half of that is 15778476.
849 ;; Write the constant explicitly to avoid roundoff error.
850 (past-cutoff -
15778476)) ; half a Gregorian year
852 ;; Use traditional time format in the C or POSIX locale,
853 ;; ISO-style time format otherwise, so columns line up.
854 (let ((locale system-time-locale
))
856 (let ((vars '("LC_ALL" "LC_TIME" "LANG")))
857 (while (and vars
(not (setq locale
(getenv (car vars
)))))
858 (setq vars
(cdr vars
)))))
859 (if (member locale
'("C" "POSIX"))
862 (if (and (not (time-less-p diff past-cutoff
))
863 (not (time-less-p 0 diff
)))
864 (if (and locale
(not ls-lisp-use-localized-time-format
))
866 (nth 0 ls-lisp-format-time-list
))
867 (if (and locale
(not ls-lisp-use-localized-time-format
))
869 (nth 1 ls-lisp-format-time-list
)))
871 (error "Unk 0 0000"))))
873 (defun ls-lisp-format-file-size (file-size human-readable
)
874 (if (not human-readable
)
875 (format (if (floatp file-size
)
876 ls-lisp-filesize-f-fmt
877 ls-lisp-filesize-d-fmt
)
879 (format " %6s" (file-size-human-readable file-size
))))
881 (defun ls-lisp-unload-function ()
882 "Unload ls-lisp library."
883 (advice-remove 'insert-directory
#'ls-lisp--insert-directory
)
884 (advice-remove 'dired
#'ls-lisp--dired
)
885 ;; Continue standard unloading.
890 ;;; ls-lisp.el ends here