ls-lisp.el 34.9 KB
Newer Older
1
;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp  -*- lexical-binding: t -*-
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1992, 1994, 2000-2019 Free Software Foundation, Inc.
Erik Naggum's avatar
Erik Naggum committed
4

5 6
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
;; 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
Sebastian Kremer's avatar
Sebastian Kremer committed
10

Erik Naggum's avatar
Erik Naggum committed
11
;; This file is part of GNU Emacs.
Sebastian Kremer's avatar
Sebastian Kremer committed
12

13
;; GNU Emacs is free software: you can redistribute it and/or modify
Sebastian Kremer's avatar
Sebastian Kremer committed
14
;; it under the terms of the GNU General Public License as published by
15 16
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Erik Naggum's avatar
Erik Naggum committed
17 18

;; GNU Emacs is distributed in the hope that it will be useful,
Sebastian Kremer's avatar
Sebastian Kremer committed
19 20 21
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
Erik Naggum's avatar
Erik Naggum committed
22

Sebastian Kremer's avatar
Sebastian Kremer committed
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/>.
Erik Naggum's avatar
Erik Naggum committed
25 26

;;; Commentary:
27

28
;; OVERVIEW ==========================================================
Sebastian Kremer's avatar
Sebastian Kremer committed
29

Glenn Morris's avatar
Glenn Morris committed
30 31 32
;; This file advises the function `insert-directory' to implement it
;; directly from Emacs lisp, without running ls in a subprocess.
;; This is useful if you don't have ls installed (ie, on MS Windows).
33

34 35 36 37
;; This function can use regexps instead of shell wildcards.  If you
;; enter regexps remember to double each $ sign.  For example, to
;; include files *.el, enter `.*\.el$$', resulting in the regexp
;; `.*\.el$'.
38

39
;; RESTRICTIONS ======================================================
40

41 42
;; * A few obscure ls switches are still ignored: see the docstring of
;; `insert-directory'.
Sebastian Kremer's avatar
Sebastian Kremer committed
43

44
;; TO DO =============================================================
45

46
;; Complete handling of F switch (if/when possible).
47

48 49 50
;; FJW: May be able to sort much faster by consing the sort key onto
;; the front of each list element, sorting and then stripping the key
;; off again!
51

52
;;; History:
53

54 55
;; Written originally by Sebastian Kremer <sk@thp.uni-koeln.de>
;; Revised by Andrew Innes and Geoff Volker (and maybe others).
56

57
;; Modified by Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>, mainly
Lars Hansen's avatar
Lars Hansen committed
58 59
;; to support many more ls options, "platform emulation" and more
;; robust sorting.
60 61

;;; Code:
62

63 64


65 66
(defgroup ls-lisp nil
  "Emulate the ls program completely in Emacs Lisp."
67
  :version "21.1"
68 69
  :group 'dired)

70 71 72 73 74
(defun ls-lisp-set-options ()
  "Reset the ls-lisp options that depend on `ls-lisp-emulation'."
  (mapc 'custom-reevaluate-setting
	'(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)
Paul Eggert's avatar
Paul Eggert committed
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 82 83 84 85 86 87 88 89 90 91
Corresponding value is one of: nil, `MacOS', `MS-Windows', `UNIX'.
Set this to your preferred value; it need not match the actual platform
you are using.

This variable does not affect the behavior of ls-lisp directly.
Rather, it controls the default values for some variables that do:
`ls-lisp-ignore-case', `ls-lisp-dirs-first', and `ls-lisp-verbosity'.

If you change this variable directly (without using customize)
after loading `ls-lisp', you should use `ls-lisp-set-options' to
update the dependent variables."
92 93 94 95
  :type '(choice (const :tag "GNU" nil)
		 (const MacOS)
		 (const MS-Windows)
		 (const UNIX))
96 97 98 99 100
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (unless (equal value (eval symbol))
	   (custom-set-default symbol value)
	   (ls-lisp-set-options)))
101 102
  :group 'ls-lisp)

Glenn Morris's avatar
Glenn Morris committed
103 104 105 106 107 108 109 110
;; Only made an obsolete alias in 23.3.  Before that, the initial
;; value was set according to:
;;  (or (memq ls-lisp-emulation '(MS-Windows MacOS))
;;      (and (boundp 'ls-lisp-dired-ignore-case) ls-lisp-dired-ignore-case))
;; Which isn't the right thing to do.
(define-obsolete-variable-alias 'ls-lisp-dired-ignore-case
  'ls-lisp-ignore-case "21.1")

111
(defcustom ls-lisp-ignore-case
Glenn Morris's avatar
Glenn Morris committed
112
  (memq ls-lisp-emulation '(MS-Windows MacOS))
Lute Kamstra's avatar
Lute Kamstra committed
113
  "Non-nil causes ls-lisp alphabetic sorting to ignore case."
Glenn Morris's avatar
Glenn Morris committed
114
  :set-after '(ls-lisp-emulation)
115 116 117
  :type 'boolean
  :group 'ls-lisp)

118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
(defcustom ls-lisp-use-string-collate
  (cond ((memq ls-lisp-emulation '(MacOS UNIX)) nil)
	(t t))		; GNU/Linux or MS-Windows emulate GNU ls
  "Non-nil causes ls-lisp to sort files in locale-dependent collation order.

A value of nil means use ordinary string comparison (see `compare-strings')
for sorting files.  A non-nil value uses `string-collate-lessp' instead,
which more closely emulates what GNU `ls' does.

On GNU/Linux systems, if the locale's codeset specifies UTF-8, as
in \"en_US.UTF-8\", the collation order follows the Unicode
Collation Algorithm (UCA), which places together file names that
differ only in punctuation characters.  On MS-Windows, customize
the option `ls-lisp-UCA-like-collation' to a non-nil value to get
similar behavior."
Stefan Monnier's avatar
Stefan Monnier committed
133
  :version "25.1"
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
  :set-after '(ls-lisp-emulation)
  :type 'boolean
  :group 'ls-lisp)

(defcustom ls-lisp-UCA-like-collation t
  "Non-nil means force ls-lisp use a collation order compatible with UCA.

UCA is the Unicode Collation Algorithm.  GNU/Linux systems automatically
follow it in their string-collation routines if the locale specifies
UTF-8 as its codeset.  On MS-Windows, customize this option to a non-nil
value to get similar behavior.

When this option is non-nil, and `ls-lisp-use-string-collate' is also
non-nil, the collation order produced on MS-Windows will ignore
punctuation and symbol characters, which will, for example, place
149
`.foo' near `foo'.  See the documentation of `string-collate-lessp'
150 151 152 153 154
and `w32-collate-ignore-punctuation' for more details.

This option is ignored on platforms other than MS-Windows; to
control the collation ordering of the file names on those other
systems, set your locale instead."
Stefan Monnier's avatar
Stefan Monnier committed
155
  :version "25.1"
156 157 158
  :type 'boolean
  :group 'ls-lisp)

159
(defcustom ls-lisp-dirs-first (eq ls-lisp-emulation 'MS-Windows)
Lute Kamstra's avatar
Lute Kamstra committed
160
  "Non-nil causes ls-lisp to sort directories first in any ordering.
161 162
\(Or last if it is reversed.)  Follows Microsoft Windows Explorer."
  ;; Functionality suggested by Chris McMahan <cmcmahan@one.net>
Glenn Morris's avatar
Glenn Morris committed
163
  :set-after '(ls-lisp-emulation)
164 165 166 167 168 169 170 171 172 173
  :type 'boolean
  :group 'ls-lisp)

(defcustom ls-lisp-verbosity
  (cond ((eq ls-lisp-emulation 'MacOS) nil)
	((eq ls-lisp-emulation 'MS-Windows)
	 (if (and (fboundp 'w32-using-nt) (w32-using-nt))
	     '(links)))			; distinguish NT/2K from 9x
	((eq ls-lisp-emulation 'UNIX) '(links uid)) ; UNIX ls
	(t '(links uid gid)))		; GNU ls
Lute Kamstra's avatar
Lute Kamstra committed
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.
177 178

Concepts come from UNIX: `links' means count of names associated with
Glenn Morris's avatar
Glenn Morris committed
179
the file; `uid' means user (owner) identifier; `gid' means group
180 181
identifier.

Glenn Morris's avatar
Glenn Morris committed
182
If emulation is MacOS then default is nil;
183
if emulation is MS-Windows then default is `(links)' if platform is
Glenn Morris's avatar
Glenn Morris committed
184 185
Windows NT/2K, nil otherwise;
if emulation is UNIX then default is `(links uid)';
186
if emulation is GNU then default is `(links uid gid)'."
Glenn Morris's avatar
Glenn Morris committed
187
  :set-after '(ls-lisp-emulation)
188 189 190 191 192 193
  ;; Functionality suggested by Howard Melman <howard@silverstream.com>
  :type '(set (const :tag "Show Link Count" links)
	      (const :tag "Show User" uid)
	      (const :tag "Show Group" gid))
  :group 'ls-lisp)

194
(defcustom ls-lisp-use-insert-directory-program
195
  (not (memq system-type '(ms-dos windows-nt)))
Lute Kamstra's avatar
Lute Kamstra committed
196
  "Non-nil causes ls-lisp to revert back to using `insert-directory-program'.
197 198
This is useful on platforms where ls-lisp is dumped into Emacs, such as
Microsoft Windows, but you would still like to use a program to list
199 200 201 202
the contents of a directory."
  :type 'boolean
  :group 'ls-lisp)

203 204
;;; Autoloaded because it is let-bound in `recover-session', `mail-recover-1'.
;;;###autoload
205
(defcustom ls-lisp-support-shell-wildcards t
Lute Kamstra's avatar
Lute Kamstra committed
206
  "Non-nil means ls-lisp treats file patterns as shell wildcards.
207 208 209 210
Otherwise they are treated as Emacs regexps (for backward compatibility)."
  :type 'boolean
  :group 'ls-lisp)

211 212 213
(defcustom ls-lisp-format-time-list
  '("%b %e %H:%M"
    "%b %e  %Y")
Lute Kamstra's avatar
Lute Kamstra committed
214
  "List of `format-time-string' specs to display file time stamps.
215 216 217 218
These specs are used ONLY if a valid locale can not be determined.

If `ls-lisp-use-localized-time-format' is non-nil, these specs are used
regardless of whether the locale can be determined.
219 220 221 222

Syntax:  (EARLY-TIME-FORMAT OLD-TIME-FORMAT)

The EARLY-TIME-FORMAT is used if file has been modified within the
Glenn Morris's avatar
Glenn Morris committed
223
current year.  The OLD-TIME-FORMAT is used for older files.  To use ISO
224 225 226
8601 dates, you could set:

\(setq ls-lisp-format-time-list
227
       \\='(\"%Y-%m-%d %H:%M\"
228
         \"%Y-%m-%d      \"))"
229 230
  :type '(list (string :tag "Early time format")
	       (string :tag "Old time format"))
231 232
  :group 'ls-lisp)

233
(defcustom ls-lisp-use-localized-time-format nil
Glenn Morris's avatar
Glenn Morris committed
234 235
  "Non-nil means to always use `ls-lisp-format-time-list' for time stamps.
This applies even if a valid locale is specified.
236 237

WARNING: Using localized date/time format might cause Dired columns
Glenn Morris's avatar
Glenn Morris committed
238
to fail to line up, e.g. if month names are not all of the same length."
239 240 241
  :type 'boolean
  :group 'ls-lisp)

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.")
Tino Calancha's avatar
Tino Calancha committed
250
(defvar ls-lisp-filesize-d-fmt " %d"
251
  "Format to display integer file sizes.")
Tino Calancha's avatar
Tino Calancha committed
252
(defvar ls-lisp-filesize-f-fmt " %.0f"
253
  "Format to display float file sizes.")
Tino Calancha's avatar
Tino Calancha committed
254
(defvar ls-lisp-filesize-b-fmt " %.0f"
255
  "Format to display file sizes in blocks (for the -s switch).")
256 257

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
258

259
(defun ls-lisp--insert-directory (orig-fun file switches &optional wildcard full-directory-p)
260 261 262 263 264 265 266
  "Insert directory listing for FILE, formatted according to SWITCHES.
Leaves point after the inserted text.
SWITCHES may be a string of options, or a list of strings.
Optional third arg WILDCARD means treat FILE as shell wildcard.
Optional fourth arg FULL-DIRECTORY-P means file is a directory and
switches do not contain `d', so that a full listing is expected.

267 268
This version of the function comes from `ls-lisp.el'.
If the value of `ls-lisp-use-insert-directory-program' is non-nil then
269 270 271 272
this advice just delegates the work to ORIG-FUN (the normal `insert-directory'
function from `files.el').
But if the value of `ls-lisp-use-insert-directory-program' is nil
then it runs a Lisp emulation.
273 274 275 276 277

The Lisp emulation does not run any external programs or shells.  It
supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards'
is non-nil; otherwise, it interprets wildcards as regular expressions
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
Eli Zaretskii's avatar
Eli Zaretskii committed
279
is assumed to be always present and cannot be turned off."
280
  (if ls-lisp-use-insert-directory-program
281
      (funcall orig-fun
282
	       file switches wildcard full-directory-p)
283 284
    ;; We need the directory in order to find the right handler.
    (let ((handler (find-file-name-handler (expand-file-name file)
285
					   'insert-directory))
286
	  (orig-file file)
287
	  wildcard-regexp)
288 289 290
      (if handler
	  (funcall handler 'insert-directory file switches
		   wildcard full-directory-p)
291 292 293
	;; Remove --dired switch
	(if (string-match "--dired " switches)
	    (setq switches (replace-match "" nil nil switches)))
294
	;; Convert SWITCHES to a list of characters.
Eli Zaretskii's avatar
Eli Zaretskii committed
295
	(setq switches (delete ?\  (delete ?- (append switches nil))))
296 297 298 299
	;; Sometimes we get ".../foo*/" as FILE.  While the shell and
	;; `ls' don't mind, we certainly do, because it makes us think
	;; there is no wildcard, only a directory name.
	(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)))
304 305 306 307
	    (progn
	      (or (not (eq (aref file (1- (length file))) ?/))
		  (setq file (substring file 0 (1- (length file)))))
	      (setq wildcard t)))
308
	(if wildcard
309
	    (setq wildcard-regexp
310 311 312 313
		  (if ls-lisp-support-shell-wildcards
		      (wildcard-to-regexp (file-name-nondirectory file))
		    (file-name-nondirectory file))
		  file (file-name-directory file))
314
	  (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
	(condition-case err
	    (ls-lisp-insert-directory
	     file switches (ls-lisp-time-index switches)
	     wildcard-regexp full-directory-p)
	  (invalid-regexp
	   ;; Maybe they wanted a literal file that just happens to
	   ;; use characters special to shell wildcards.
	   (if (equal (cadr err) "Unmatched [ or [^")
	       (progn
		 (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'")
		       file (file-relative-name orig-file))
		 (ls-lisp-insert-directory
		  file switches (ls-lisp-time-index switches)
		  nil full-directory-p))
	     (signal (car err) (cdr err)))))
330 331 332 333 334 335 336
	;; Try to insert the amount of free space.
	(save-excursion
	  (goto-char (point-min))
	  ;; First find the line to put it on.
	  (when (re-search-forward "^total" nil t)
	    (let ((available (get-free-disk-space ".")))
	      (when available
337 338
		;; Replace "total" with "total used", to avoid confusion.
		(replace-match "total used in directory")
339 340
		(end-of-line)
		(insert " available " available)))))))))
341
(advice-add 'insert-directory :around #'ls-lisp--insert-directory)
342 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 347 348 349
Leaves point after the inserted text.  This is an internal function
optionally called by the `ls-lisp.el' version of `insert-directory'.
It is called recursively if the -R switch is used.
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 352
regexp*.  FULL-DIRECTORY-P means file is a directory and SWITCHES does
not contain `d', so that a full listing is expected."
353 354 355
  (if (or (and wildcard-regexp
               (not (string= "[^~]\\'" wildcard-regexp))) ; Switch -B pseudo-wildcard regexp
          full-directory-p)
356 357 358
      (let* ((dir (file-name-as-directory file))
	     (default-directory dir)	; so that file-attributes works
	     (file-alist
359 360 361 362
	      (directory-files-and-attributes dir nil wildcard-regexp t
					      (if (memq ?n switches)
						  'integer
						'string)))
363
	     (sum 0)
364 365 366
	     (max-uid-len 0)
	     (max-gid-len 0)
	     (max-file-size 0)
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 372 373 374 375 376 377 378 379 380 381 382
	(cond ((memq ?A switches)
	       (setq file-alist
		     (ls-lisp-delete-matching "^\\.\\.?$" file-alist)))
	      ((not (memq ?a switches))
	       ;; if neither -A  nor -a, flush . files
	       (setq file-alist
		     (ls-lisp-delete-matching "^\\." file-alist))))
	(setq file-alist
	      (ls-lisp-handle-switches file-alist switches))
	(if (memq ?C switches)		; column (-C) format
	    (ls-lisp-column-format file-alist)
	  (setq total-line (cons (point) (car-safe file-alist)))
383 384 385 386 387
	  ;; Find the appropriate format for displaying uid, gid, and
	  ;; file size, by finding the longest strings among all the
	  ;; files we are about to display.
	  (dolist (elt file-alist)
	    (setq attr (cdr elt)
Paul Eggert's avatar
Paul Eggert committed
388
		  fuid (file-attribute-user-id attr)
389 390
		  uid-len (if (stringp fuid) (string-width fuid)
			    (length (format "%d" fuid)))
Paul Eggert's avatar
Paul Eggert committed
391
		  fgid (file-attribute-group-id attr)
392 393
		  gid-len (if (stringp fgid) (string-width fgid)
			    (length (format "%d" fgid)))
Paul Eggert's avatar
Paul Eggert committed
394
		  file-size (file-attribute-size attr))
395 396 397 398 399 400 401 402 403 404 405
	    (if (> uid-len max-uid-len)
		(setq max-uid-len uid-len))
	    (if (> gid-len max-gid-len)
		(setq max-gid-len gid-len))
	    (if (> file-size max-file-size)
		(setq max-file-size file-size)))
	  (setq ls-lisp-uid-d-fmt (format " %%-%dd" max-uid-len))
	  (setq ls-lisp-uid-s-fmt (format " %%-%ds" max-uid-len))
	  (setq ls-lisp-gid-d-fmt (format " %%-%dd" max-gid-len))
	  (setq ls-lisp-gid-s-fmt (format " %%-%ds" max-gid-len))
	  (setq ls-lisp-filesize-d-fmt
406
		(format " %%%dd" (length (format "%.0f" max-file-size))))
407
	  (setq ls-lisp-filesize-f-fmt
408 409 410 411
		(format " %%%d.0f" (length (format "%.0f" max-file-size))))
	  (if (memq ?s switches)
	      (setq ls-lisp-filesize-b-fmt
		    (format "%%%d.0f "
412
			    (length (format "%.0f"
413 414
					    (fceiling
					     (/ max-file-size 1024.0)))))))
415 416 417 418 419 420
	  (setq files file-alist)
	  (while files			; long (-l) format
	    (setq elt (car files)
		  files (cdr files)
		  short (car elt)
		  attr (cdr elt)
Paul Eggert's avatar
Paul Eggert committed
421
		  file-size (file-attribute-size attr))
422 423 424 425 426 427 428 429 430 431
	    (and attr
		 (setq sum (+ file-size
			      ;; Even if neither SUM nor file's size
			      ;; overflow, their sum could.
			      (if (or (< sum (- 134217727 file-size))
				      (floatp sum)
				      (floatp file-size))
				  sum
				(float sum))))
		 (insert (ls-lisp-format short attr file-size
Glenn Morris's avatar
Glenn Morris committed
432
					 switches time-index))))
433 434 435 436 437 438 439 440
	  ;; Insert total size of all files:
	  (save-excursion
	    (goto-char (car total-line))
	    (or (cdr total-line)
		;; Shell says ``No match'' if no files match
		;; the wildcard; let's say something similar.
		(insert "(No match)\n"))
	    (insert (format "total %.0f\n" (fceiling (/ sum 1024.0))))))
441 442
	;; dired-insert-directory expects to find point after the
	;; text.  But if the listing is empty, as e.g. in empty
443 444 445 446 447
	;; directories with -a removed from switches, point will be
	;; before the inserted text, and dired-insert-directory will
	;; not indent the listing correctly.  Going to the end of the
	;; buffer fixes that.
	(unless files (goto-char (point-max)))
448 449 450 451 452
	(if (memq ?R switches)
	    ;; List the contents of all directories recursively.
	    ;; cadr of each element of `file-alist' is t for
	    ;; directory, string (name linked to) for symbolic
	    ;; link, or nil.
453 454
	    (while file-alist
	      (setq elt (car file-alist)
455 456
		    file-alist (cdr file-alist))
	      (when (and (eq (cadr elt) t) ; directory
457 458 459 460
			 ;; Under -F, we have already decorated all
			 ;; directories, including "." and "..", with
			 ;; a /, so allow for that as well.
			 (not (string-match "\\`\\.\\.?/?\\'" (car elt))))
461 462 463
		(setq elt (expand-file-name (car elt) dir))
		(insert "\n" elt ":\n")
		(ls-lisp-insert-directory
464
		 elt switches time-index wildcard-regexp full-directory-p)))))
465 466 467
    ;; If not full-directory-p, FILE *must not* end in /, as
    ;; file-attributes will not recognize a symlink to a directory,
    ;; so must make it a relative filename as ls does:
468
    (if (file-name-absolute-p file) (setq file (expand-file-name file)))
469 470
    (if (eq (aref file (1- (length file))) ?/)
	(setq file (substring file 0 -1)))
471
    (let ((fattr (file-attributes file 'string)))
472
      (if fattr
Eli Zaretskii's avatar
Eli Zaretskii committed
473 474 475 476
	  (insert (ls-lisp-format
		   (if (memq ?F switches)
		       (ls-lisp-classify-file file fattr)
		     file)
Paul Eggert's avatar
Paul Eggert committed
477
		   fattr (file-attribute-size fattr)
478 479 480 481 482 483 484
                   switches time-index))
        ;; Emulate what we do on Posix hosts when we call access-file
        ;; in insert-directory.
	(signal 'file-error
                (list "Reading directory"
                      "Directory doesn't exist or is inaccessible"
                      file))))))
485

486 487 488
(declare-function dired-read-dir-and-switches "dired" (str))
(declare-function dired-goto-next-file "dired" ())

489 490
(defun ls-lisp--dired (orig-fun dir-or-list &optional switches)
  (interactive (dired-read-dir-and-switches ""))
491 492
  (unless dir-or-list
    (setq dir-or-list default-directory))
493 494 495 496 497 498 499
  (if (consp dir-or-list)
      (funcall orig-fun dir-or-list switches)
    (let ((dir-wildcard (insert-directory-wildcard-in-dir-p
                         (expand-file-name dir-or-list))))
      (if (not dir-wildcard)
          (funcall orig-fun dir-or-list switches)
        (let* ((default-directory (car dir-wildcard))
500
               (files (file-expand-wildcards (cdr dir-wildcard)))
501 502 503 504 505 506 507 508 509 510 511 512 513 514 515
               (dir (car dir-wildcard)))
          (if files
              (let ((inhibit-read-only t)
                    (buf
                     (apply orig-fun (nconc (list dir) files) (and switches (list switches)))))
                (with-current-buffer buf
                  (save-excursion
                    (goto-char (point-min))
                    (dired-goto-next-file)
                    (forward-line 0)
                    (insert "  wildcard " (cdr dir-wildcard) "\n"))))
            (user-error "No files matching regexp")))))))

(advice-add 'dired :around #'ls-lisp--dired)

516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531
(defun ls-lisp-sanitize (file-alist)
  "Sanitize the elements in FILE-ALIST.
Fixes any elements in the alist for directory entries whose file
attributes are nil (meaning that `file-attributes' failed for
them).  This is known to happen for some network shares, in
particular for the \"..\" directory entry.

If the \"..\" directory entry has nil attributes, the attributes
are copied from the \".\" entry, if they are non-nil.  Otherwise,
the offending element is removed from the list, as are any
elements for other directory entries with nil attributes."
  (if (and (null (cdr (assoc ".." file-alist)))
	   (cdr (assoc "." file-alist)))
      (setcdr (assoc ".." file-alist) (cdr (assoc "." file-alist))))
  (rassq-delete-all nil file-alist))

532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564
(defun ls-lisp-column-format (file-alist)
  "Insert the file names (only) in FILE-ALIST into the current buffer.
Format in columns, sorted vertically, following GNU ls -C.
Responds to the window width as ls should but may not!"
  (let (files fmt ncols collen (nfiles 0) (colwid 0))
    ;; Count number of files as `nfiles', build list of filenames as
    ;; `files', and find maximum filename length as `colwid':
    (let (file len)
      (while file-alist
	(setq nfiles (1+ nfiles)
	      file (caar file-alist)
	      files (cons file files)
	      file-alist (cdr file-alist)
	      len (length file))
	(if (> len colwid) (setq colwid len))))
    (setq files (nreverse files)
	  colwid (+ 2 colwid)		; 2 character column gap
	  fmt (format "%%-%ds" colwid)	; print format
	  ncols (/ (window-width) colwid) ; no of columns
	  collen (/ nfiles ncols))	; floor of column length
    (if (> nfiles (* collen ncols)) (setq collen (1+ collen)))
    ;; Output the file names in columns, sorted vertically:
    (let ((i 0) j)
      (while (< i collen)
	(setq j i)
	(while (< j nfiles)
	  (insert (format fmt (nth j files)))
	  (setq j (+ j collen)))
	;; FJW: This is completely unnecessary, but I don't like
	;; trailing white space...
	(delete-region (point) (progn (skip-chars-backward " \t") (point)))
	(insert ?\n)
	(setq i (1+ i))))))
565 566

(defun ls-lisp-delete-matching (regexp list)
567
  "Delete all elements matching REGEXP from LIST, return new list."
568
  ;; Should perhaps use setcdr for efficiency.
569 570
  (let (result)
    (while list
571
      (or (string-match regexp (caar list))
572 573 574 575
	  (setq result (cons (car list) result)))
      (setq list (cdr list)))
    result))

576 577
(defvar w32-collate-ignore-punctuation) ; Declare for non-w32 builds.

578
(defsubst ls-lisp-string-lessp (s1 s2)
579
  "Return t if string S1 should sort before string S2.
580
Case is significant if `ls-lisp-ignore-case' is nil.
581
Uses `string-collate-lessp' if `ls-lisp-use-string-collate' is non-nil,
582
`compare-strings' otherwise.
583 584 585
On GNU/Linux systems, if the locale specifies UTF-8 as the codeset,
the sorting order will place together file names that differ only
by punctuation characters, like `.emacs' and `emacs'.  To have a
Paul Eggert's avatar
Paul Eggert committed
586
similar behavior on MS-Windows, customize `ls-lisp-UCA-like-collation'
587 588 589 590 591 592
to a non-nil value."
  (let ((w32-collate-ignore-punctuation ls-lisp-UCA-like-collation))
    (if ls-lisp-use-string-collate
	(string-collate-lessp s1 s2 nil ls-lisp-ignore-case)
      (let ((u (compare-strings s1 0 nil s2 0 nil ls-lisp-ignore-case)))
	(and (numberp u) (< u 0))))))
593

594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654
(defun ls-lisp-version-lessp (s1 s2)
  "Return t if versioned string S1 should sort before versioned string S2.

Case is significant if `ls-lisp-ignore-case' is nil.
This is the same as string-lessp (with the exception of case
insensitivity), but sequences of digits are compared numerically,
as a whole, in the same manner as the `strverscmp' function available
in some standard C libraries does."
  (let ((i1 0)
	(i2 0)
	(len1 (length s1))
	(len2 (length s2))
	(val 0)
	ni1 ni2 e1 e2 found-2-numbers-p)
    (while (and (< i1 len1) (< i2 len2) (zerop val))
      (unless found-2-numbers-p
	(setq ni1 (string-match "[0-9]+" s1 i1)
	      e1 (match-end 0))
	(setq ni2 (string-match "[0-9]+" s2 i2)
	      e2 (match-end 0)))
      (cond
       ((and ni1 ni2)
	(cond
	 ((and (> ni1 i1) (> ni2 i2))
	  ;; Compare non-numerical part as strings.
	  (setq val (compare-strings s1 i1 ni1 s2 i2 ni2 ls-lisp-ignore-case)
		i1 ni1
		i2 ni2
		found-2-numbers-p t))
	 ((and (= ni1 i1) (= ni2 i2))
	  (setq found-2-numbers-p nil)
	  ;; Compare numerical parts as integral and/or fractional parts.
	  (let* ((sub1 (substring s1 ni1 e1))
		 (sub2 (substring s2 ni2 e2))
		 ;; "Fraction" is a numerical sequence with leading zeros.
		 (fr1 (string-match "\\`0+" sub1))
		 (fr2 (string-match "\\`0+" sub2)))
	    (cond
	     ((and fr1 fr2)	; two fractions, the shortest wins
	      (setq val (- val (- (length sub1) (length sub2)))))
	     (fr1		; a fraction is always less than an integral
	      (setq val (- ni1)))
	     (fr2
	      (setq val ni2)))
	    (if (zerop val)	; fall back on numerical comparison
		(setq val (- (string-to-number sub1)
			     (string-to-number sub2))))
	    (setq i1 e1
		  i2 e2)))
	 (t
	  (setq val (compare-strings s1 i1 nil s2 i2 nil ls-lisp-ignore-case)
		i1 len1
		i2 len2))))
       (t (setq val (compare-strings s1 i1 nil s2 i2 nil ls-lisp-ignore-case)
		i1 len1
		i2 len2)))
      (and (eq val t) (setq val 0)))
    (if (zerop val)
	(setq val (- len1 len2)))
    (< val 0)))

655
(defun ls-lisp-handle-switches (file-alist switches)
656 657
  "Return new FILE-ALIST sorted according to SWITCHES.
SWITCHES is a list of characters.  Default sorting is alphabetic."
658
  ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
659 660 661 662 663 664 665 666 667 668
  (or (memq ?U switches)		; unsorted
      ;; Catch and ignore unexpected sorting errors
      (condition-case err
	  (setq file-alist
		(let (index)
		  ;; Copy file-alist in case of error
		  (sort (copy-sequence file-alist) ; modifies its argument!
			(cond ((memq ?S switches)
			       (lambda (x y) ; sorted on size
				 ;; Make largest file come first
Paul Eggert's avatar
Paul Eggert committed
669 670
				 (< (file-attribute-size (cdr y))
				    (file-attribute-size (cdr x)))))
671 672
			      ((setq index (ls-lisp-time-index switches))
			       (lambda (x y) ; sorted on time
673 674
				 (time-less-p (nth index (cdr y))
					      (nth index (cdr x)))))
675 676 677 678 679
			      ((memq ?X switches)
			       (lambda (x y) ; sorted on extension
				 (ls-lisp-string-lessp
				  (ls-lisp-extension (car x))
				  (ls-lisp-extension (car y)))))
680 681 682
			      ((memq ?v switches)
			       (lambda (x y) ; sorted by version number
				 (ls-lisp-version-lessp (car x) (car y))))
683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
			      (t
			       (lambda (x y) ; sorted alphabetically
				 (ls-lisp-string-lessp (car x) (car y))))))))
	(error (message "Unsorted (ls-lisp sorting error) - %s"
			(error-message-string err))
	       (ding) (sit-for 2))))	; to show user the message!
  (if (memq ?F switches)		; classify switch
      (setq file-alist (mapcar 'ls-lisp-classify file-alist)))
  (if ls-lisp-dirs-first
  ;; Re-sort directories first, without otherwise changing the
  ;; ordering, and reverse whole list.  cadr of each element of
  ;; `file-alist' is t for directory, string (name linked to) for
  ;; symbolic link, or nil.
      (let (el dirs files)
	(while file-alist
Lars Hansen's avatar
Lars Hansen committed
698 699 700
	  (if (or (eq (cadr (setq el (car file-alist))) t) ; directory
                  (and (stringp (cadr el))
                       (file-directory-p (cadr el)))) ; symlink to a directory
701 702 703 704 705 706 707 708 709 710
	      (setq dirs (cons el dirs))
	    (setq files (cons el files)))
	  (setq file-alist (cdr file-alist)))
	(setq file-alist
	      (if (memq ?U switches)	; unsorted order is reversed
		  (nconc dirs files)
		(nconc files dirs)
		))))
  ;; Finally reverse file alist if necessary.
  ;; (eq below MUST compare `(not (memq ...))' to force comparison of
711
  ;; t or nil, rather than list tails!)
712 713 714 715 716 717
  (if (eq (eq (not (memq ?U switches))	; unsorted order is reversed
	      (not (memq ?r switches)))	; reversed sort order requested
	  ls-lisp-dirs-first)		; already reversed
      (nreverse file-alist)
    file-alist))

Eli Zaretskii's avatar
Eli Zaretskii committed
718 719 720
(defun ls-lisp-classify-file (filename fattr)
  "Append a character to FILENAME indicating the file type.

721 722
This function puts the `dired-filename' property on FILENAME, but
not on the character indicator it appends.
Eli Zaretskii's avatar
Eli Zaretskii committed
723 724 725 726
FATTR is the file attributes returned by `file-attributes' for the file.
The file type indicators are `/' for directories, `@' for symbolic
links, `|' for FIFOs, `=' for sockets, `*' for regular files that
are executable, and nothing for other types of files."
Paul Eggert's avatar
Paul Eggert committed
727 728
  (let* ((type (file-attribute-type fattr))
	 (modestr (file-attribute-modes fattr))
729 730
	 (typestr (substring modestr 0 1))
         (file-name (propertize filename 'dired-filename t)))
Eli Zaretskii's avatar
Eli Zaretskii committed
731 732
    (cond
     (type
733
      (concat file-name (if (eq type t) "/" "@")))
Eli Zaretskii's avatar
Eli Zaretskii committed
734
     ((string-match "x" modestr)
735
      (concat file-name "*"))
Eli Zaretskii's avatar
Eli Zaretskii committed
736
     ((string= "p" typestr)
737
      (concat file-name "|"))
Eli Zaretskii's avatar
Eli Zaretskii committed
738
     ((string= "s" typestr)
739 740
      (concat file-name "="))
     (t file-name))))
Eli Zaretskii's avatar
Eli Zaretskii committed
741

742
(defun ls-lisp-classify (filedata)
Eli Zaretskii's avatar
Eli Zaretskii committed
743 744 745 746 747
  "Append a character to file name in FILEDATA indicating the file type.

FILEDATA has the form (FILENAME . ATTRIBUTES), where ATTRIBUTES is the
structure returned by `file-attributes' for that file.

748
The file type indicators are `/' for directories, `@' for symbolic
Eli Zaretskii's avatar
Eli Zaretskii committed
749 750
links, `|' for FIFOs, `=' for sockets, `*' for regular files that
are executable, and nothing for other types of files."
Lars Hansen's avatar
Lars Hansen committed
751
  (let ((file-name (car filedata))
Eli Zaretskii's avatar
Eli Zaretskii committed
752 753
        (fattr (cdr filedata)))
    (cons (ls-lisp-classify-file file-name fattr) fattr)))
754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775

(defun ls-lisp-extension (filename)
  "Return extension of FILENAME (ignoring any version extension)
FOLLOWED by null and full filename, SOLELY for full alpha sort."
  ;; Force extension sort order: `no ext' then `null ext' then `ext'
  ;; to agree with GNU ls.
  (concat
   (let* ((i (length filename)) end)
     (if (= (aref filename (1- i)) ?.) ; null extension
	 "\0"
       (while (and (>= (setq i (1- i)) 0)
		   (/= (aref filename i) ?.)))
       (if (< i 0) "\0\0"		; no extension
	 (if (/= (aref filename (1+ i)) ?~)
	     (substring filename (1+ i))
	   ;; version extension found -- ignore it
	   (setq end i)
	   (while (and (>= (setq i (1- i)) 0)
		       (/= (aref filename i) ?.)))
	   (if (< i 0) "\0\0"	; no extension
	     (substring filename (1+ i) end))))
       )) "\0" filename))
Sebastian Kremer's avatar
Sebastian Kremer committed
776

Glenn Morris's avatar
Glenn Morris committed
777
(defun ls-lisp-format (file-name file-attr file-size switches time-index)
778 779
  "Format one line of long ls output for file FILE-NAME.
FILE-ATTR and FILE-SIZE give the file's attributes and size.
Glenn Morris's avatar
Glenn Morris committed
780
SWITCHES and TIME-INDEX give the full switch list and time data."
Paul Eggert's avatar
Paul Eggert committed
781
  (let ((file-type (file-attribute-type file-attr))
782 783
	;; t for directory, string (name linked to)
	;; for symbolic link, or nil.
Paul Eggert's avatar
Paul Eggert committed
784
	(drwxrwxrwx (file-attribute-modes file-attr)))
785
    (concat (if (memq ?i switches)	; inode number
Paul Eggert's avatar
Paul Eggert committed
786 787
		(let ((inode (file-attribute-inode-number file-attr)))
		  (format " %18d " inode)))
788
	    ;; nil is treated like "" in concat
789 790 791 792 793 794 795 796 797 798 799 800 801 802
	    (if (memq ?s switches)	; size in K, rounded up
		;; In GNU ls, -h affects the size in blocks, displayed
		;; by -s, as well.
		(if (memq ?h switches)
		    (format "%6s "
			    (file-size-human-readable
			     ;; We use 1K as "block size", although
			     ;; most Windows volumes use 4KB to 8KB
			     ;; clusters, and exFAT will usually have
			     ;; clusters of 32KB or even 128KB.  See
			     ;; KB article 140365 for the details.
			     (* 1024.0 (fceiling (/ file-size 1024.0)))))
		  (format ls-lisp-filesize-b-fmt
			  (fceiling (/ file-size 1024.0)))))
803 804
	    drwxrwxrwx			; attribute string
	    (if (memq 'links ls-lisp-verbosity)
Paul Eggert's avatar
Paul Eggert committed
805
		(format "%3d" (file-attribute-link-number file-attr)))
806
	    ;; Numeric uid/gid are more confusing than helpful;
807
	    ;; Emacs should be able to make strings of them.
808 809 810
	    ;; They tend to be bogus on non-UNIX platforms anyway so
	    ;; optionally hide them.
	    (if (memq 'uid ls-lisp-verbosity)
811
		;; uid can be a string or an integer
Paul Eggert's avatar
Paul Eggert committed
812
		(let ((uid (file-attribute-user-id file-attr)))
813 814 815 816
                  (format (if (stringp uid)
			      ls-lisp-uid-s-fmt
			    ls-lisp-uid-d-fmt)
			  uid)))
817 818 819
	    (if (not (memq ?G switches)) ; GNU ls -- shows group by default
		(if (or (memq ?g switches) ; UNIX ls -- no group by default
			(memq 'gid ls-lisp-verbosity))
Paul Eggert's avatar
Paul Eggert committed
820
                    (let ((gid (file-attribute-group-id file-attr)))
821 822 823 824
                      (format (if (stringp gid)
				  ls-lisp-gid-s-fmt
				ls-lisp-gid-d-fmt)
			      gid))))
825
	    (ls-lisp-format-file-size file-size (memq ?h switches))
826
	    " "
Glenn Morris's avatar
Glenn Morris committed
827
	    (ls-lisp-format-time file-attr time-index)
828
	    " "
829
	    (if (not (memq ?F switches)) ; ls-lisp-classify-file already did that
830 831
		(propertize file-name 'dired-filename t)
	      file-name)
Sebastian Kremer's avatar
Sebastian Kremer committed
832
	    (if (stringp file-type)	; is a symbolic link
833
		(concat " -> " file-type))
Sebastian Kremer's avatar
Sebastian Kremer committed
834 835 836
	    "\n"
	    )))

837
(defun ls-lisp-time-index (switches)
838 839 840 841 842 843 844
  "Return time index into file-attributes according to ls SWITCHES list.
Return nil if no time switch found."
  ;; FJW: Default of nil is IMPORTANT and used in `ls-lisp-handle-switches'!
  (cond ((memq ?c switches) 6)		; last mode change
	((memq ?t switches) 5)		; last modtime
	((memq ?u switches) 4)))	; last access

Glenn Morris's avatar
Glenn Morris committed
845
(defun ls-lisp-format-time (file-attr time-index)
846 847
  "Format time for file with attributes FILE-ATTR according to TIME-INDEX.
Use the same method as ls to decide whether to show time-of-day or year,
Glenn Morris's avatar
Glenn Morris committed
848
depending on distance between file date and the current time.
849 850
All ls time options, namely c, t and u, are handled."
  (let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime
851
	 (diff (time-subtract time nil))
852 853 854 855 856
	 ;; Consider a time to be recent if it is within the past six
	 ;; months.  A Gregorian year has 365.2425 * 24 * 60 * 60 ==
	 ;; 31556952 seconds on the average, and half of that is 15778476.
	 ;; Write the constant explicitly to avoid roundoff error.
	 (past-cutoff -15778476)) ; half a Gregorian year
857
    (condition-case nil
858 859 860 861 862 863 864 865 866 867
	;; Use traditional time format in the C or POSIX locale,
	;; ISO-style time format otherwise, so columns line up.
	(let ((locale system-time-locale))
	  (if (not locale)
	      (let ((vars '("LC_ALL" "LC_TIME" "LANG")))
		(while (and vars (not (setq locale (getenv (car vars)))))
		  (setq vars (cdr vars)))))
	  (if (member locale '("C" "POSIX"))
	      (setq locale nil))
	  (format-time-string
868 869
	   (if (and (not (time-less-p diff past-cutoff))
		    (not (time-less-p 0 diff)))
870 871 872 873 874 875
	       (if (and locale (not ls-lisp-use-localized-time-format))
		   "%m-%d %H:%M"
		 (nth 0 ls-lisp-format-time-list))
	     (if (and locale (not ls-lisp-use-localized-time-format))
		 "%Y-%m-%d "
	       (nth 1 ls-lisp-format-time-list)))
876
	   time))
877
      (error "Unk  0  0000"))))
878

879
(defun ls-lisp-format-file-size (file-size human-readable)
880 881 882 883 884
  (if (not human-readable)
      (format (if (floatp file-size)
		  ls-lisp-filesize-f-fmt
		ls-lisp-filesize-d-fmt)
	      file-size)
885
    (format " %6s" (file-size-human-readable file-size))))
886

887 888 889
(defun ls-lisp-unload-function ()
  "Unload ls-lisp library."
  (advice-remove 'insert-directory #'ls-lisp--insert-directory)
890
  (advice-remove 'dired #'ls-lisp--dired)
891 892 893
  ;; Continue standard unloading.
  nil)

894
(provide 'ls-lisp)
895

896
;;; ls-lisp.el ends here