summaryrefslogtreecommitdiff
path: root/lisp/ls-lisp.el
blob: 08d07eb03a790bf64451aca6a3b84e89e2b6decd (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
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
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
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
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp

;; Copyright (C) 1992, 1994, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
;; Modified by: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>
;; Maintainer: FSF
;; Keywords: unix, dired

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; 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.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; OVERVIEW ==========================================================

;; This file redefines the function `insert-directory' to implement it
;; directly from Emacs lisp, without running ls in a subprocess.  It
;; is useful if you cannot afford to fork Emacs on a real memory UNIX,
;; under VMS or other non-UNIX platforms if you don't have the ls
;; program, or if you want a different format from what ls offers.

;; 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$'.

;; RESTRICTIONS ======================================================

;; * A few obscure ls switches are still ignored: see the docstring of
;; `insert-directory'.

;; TO DO =============================================================

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

;; 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!

;;; History:

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

;; Modified by Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>, mainly
;; to support many more ls options, "platform emulation" and more
;; robust sorting.

;;; Code:

(eval-when-compile (require 'cl))

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

(defcustom ls-lisp-emulation
  (cond ((eq system-type 'macos) 'MacOS)
	;; ((eq system-type 'windows-nt) 'MS-Windows)
	((memq system-type
	       '(hpux usg-unix-v unisoft-unix irix berkeley-unix))
	 'UNIX))			; very similar to GNU
  ;; Anything else defaults to nil, meaning GNU.
  "*Platform to emulate: GNU (default), MacOS, MS-Windows, UNIX.
Corresponding value is one of the atoms: nil, MacOS, MS-Windows, UNIX.
Sets default values for: `ls-lisp-ignore-case', `ls-lisp-dirs-first',
`ls-lisp-verbosity'.  Need not match actual platform.  Changing this
option will have no effect until you restart Emacs."
  :type '(choice (const :tag "GNU" nil)
		 (const MacOS)
		 (const MS-Windows)
		 (const UNIX))
  :group 'ls-lisp)

(defcustom ls-lisp-ignore-case
  ;; Name change for consistency with other option names.
  (or (memq ls-lisp-emulation '(MS-Windows MacOS))
      (and (boundp 'ls-lisp-dired-ignore-case) ls-lisp-dired-ignore-case))
  "*Non-nil causes ls-lisp alphabetic sorting to ignore case."
  :type 'boolean
  :group 'ls-lisp)

(defcustom ls-lisp-dirs-first (eq ls-lisp-emulation 'MS-Windows)
  "*Non-nil causes ls-lisp to sort directories first in any ordering.
\(Or last if it is reversed.)  Follows Microsoft Windows Explorer."
  ;; Functionality suggested by Chris McMahan <cmcmahan@one.net>
  :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
  "*A list of optional file attributes that ls-lisp should display.
It should contain none or more of the symbols: links, uid, gid.
A value of nil (or an empty list) means display none of them.

Concepts come from UNIX: `links' means count of names associated with
the file\; `uid' means user (owner) identifier\; `gid' means group
identifier.

If emulation is MacOS then default is nil\;
if emulation is MS-Windows then default is `(links)' if platform is
Windows NT/2K, nil otherwise\;
if emulation is UNIX then default is `(links uid)'\;
if emulation is GNU then default is `(links uid gid)'."
  ;; 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)

(defcustom ls-lisp-use-insert-directory-program
  (not (memq system-type '(macos ms-dos windows-nt)))
  "*Non-nil causes ls-lisp to revert back to using `insert-directory-program'.
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
the contents of a directory."
  :type 'boolean
  :group 'ls-lisp)

;;; Autoloaded because it is let-bound in `recover-session', `mail-recover-1'.
;;;###autoload
(defcustom ls-lisp-support-shell-wildcards t
  "*Non-nil means ls-lisp treats file patterns as shell wildcards.
Otherwise they are treated as Emacs regexps (for backward compatibility)."
  :type 'boolean
  :group 'ls-lisp)

(defcustom ls-lisp-format-time-list
  '("%b %e %H:%M"
    "%b %e  %Y")
  "*List of `format-time-string' specs to display file time stamps.
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.

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

The EARLY-TIME-FORMAT is used if file has been modified within the
current year. The OLD-TIME-FORMAT is used for older files.  To use ISO
8601 dates, you could set:

\(setq ls-lisp-format-time-list
       '(\"%Y-%m-%d %H:%M\"
         \"%Y-%m-%d      \"))"
  :type '(list (string :tag "Early time format")
	       (string :tag "Old time format"))
  :group 'ls-lisp)

(defcustom ls-lisp-use-localized-time-format nil
  "*Non-nil causes ls-lisp to use `ls-lisp-format-time-list' even if
a valid locale is specified.

WARNING: Using localized date/time format might cause Dired columns
to fail to lign up, e.g. if month names are not all of the same length."
  :type 'boolean
  :group 'ls-lisp)

(defvar original-insert-directory nil
  "This holds the original function definition of `insert-directory'.")

(defvar ls-lisp-uid-d-fmt "-%d"
  "Format to display integer UIDs.")
(defvar ls-lisp-uid-s-fmt "-%s"
  "Format to display user names.")
(defvar ls-lisp-gid-d-fmt "-%d"
  "Format to display integer GIDs.")
(defvar ls-lisp-gid-s-fmt "-%s"
  "Format to display user group names.")
(defvar ls-lisp-filesize-d-fmt "%d"
  "Format to display integer file sizes.")
(defvar ls-lisp-filesize-f-fmt "%.0f"
  "Format to display float file sizes.")

;; Remember the original insert-directory function
(or (featurep 'ls-lisp)  ; FJW: unless this file is being reloaded!
    (setq original-insert-directory (symbol-function 'insert-directory)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun insert-directory (file switches &optional wildcard full-directory-p)
  "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.

This version of the function comes from `ls-lisp.el'.
If the value of `ls-lisp-use-insert-directory-program' is non-nil then
it works exactly like the version from `files.el' and runs a directory
listing program whose name is in the variable
`insert-directory-program'; if also WILDCARD is non-nil then it runs
the shell specified by `shell-file-name'.  If the value of
`ls-lisp-use-insert-directory-program' is nil then it runs a Lisp
emulation.

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
that work are: A a c i r S s t u U X g G B C R n and F partly."
  (if ls-lisp-use-insert-directory-program
      (funcall original-insert-directory
	       file switches wildcard full-directory-p)
    ;; We need the directory in order to find the right handler.
    (let ((handler (find-file-name-handler (expand-file-name file)
					   'insert-directory))
	  (orig-file file)
	  wildcard-regexp)
      (if handler
	  (funcall handler 'insert-directory file switches
		   wildcard full-directory-p)
	;; Remove --dired switch
	(if (string-match "--dired " switches)
	    (setq switches (replace-match "" nil nil switches)))
	;; Convert SWITCHES to a list of characters.
	(setq switches (delete ?- (append switches nil)))
	;; 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
		 (string-match "[[?*]" file)
		 ;; Prefer an existing file to wildcards, like
		 ;; dired-noselect does.
		 (not (file-exists-p file)))
	    (progn
	      (or (not (eq (aref file (1- (length file))) ?/))
		  (setq file (substring file 0 (1- (length file)))))
	      (setq wildcard t)))
	(if wildcard
	    (setq wildcard-regexp
		  (if ls-lisp-support-shell-wildcards
		      (wildcard-to-regexp (file-name-nondirectory file))
		    (file-name-nondirectory file))
		  file (file-name-directory file))
	  (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
	(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)))))
	;; 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
		;; Replace "total" with "total used", to avoid confusion.
		(replace-match "total used in directory")
		(end-of-line)
		(insert " available " available)))))))))

(defun ls-lisp-insert-directory
  (file switches time-index wildcard-regexp full-directory-p)
  "Insert directory listing for FILE, formatted according to SWITCHES.
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
file-attributes according to SWITCHES.  WILDCARD-REGEXP is nil or an *Emacs
regexp*.  FULL-DIRECTORY-P means file is a directory and SWITCHES does
not contain `d', so that a full listing is expected."
  (if (or wildcard-regexp full-directory-p)
      (let* ((dir (file-name-as-directory file))
	     (default-directory dir)	; so that file-attributes works
	     (file-alist
	      (directory-files-and-attributes dir nil wildcard-regexp t
					      (if (memq ?n switches)
						  'integer
						'string)))
	     (now (current-time))
	     (sum 0)
	     (max-uid-len 0)
	     (max-gid-len 0)
	     (max-file-size 0)
	     ;; do all bindings here for speed
	     total-line files elt short file-size fil attr
	     fuid fgid uid-len gid-len)
	(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)))
	  ;; 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)
		  fuid (nth 2 attr)
		  uid-len (if (stringp fuid) (string-width fuid)
			    (length (format "%d" fuid)))
		  fgid (nth 3 attr)
		  gid-len (if (stringp fgid) (string-width fgid)
			    (length (format "%d" fgid)))
		  file-size (nth 7 attr))
	    (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
		(format " %%%dd"
			(if (memq ?s switches)
			    (length (format "%.0f"
					    (fceiling (/ max-file-size 1024.0))))
			  (length (format "%.0f" max-file-size)))))
	  (setq ls-lisp-filesize-f-fmt
		(format " %%%d.0f"
			(if (memq ?s switches)
			    (length (format "%.0f"
					    (fceiling (/ max-file-size 1024.0))))
			  (length (format "%.0f" max-file-size)))))
	  (setq files file-alist)
	  (while files			; long (-l) format
	    (setq elt (car files)
		  files (cdr files)
		  short (car elt)
		  attr (cdr elt)
		  file-size (nth 7 attr))
	    (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
					 switches time-index now))))
	  ;; 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))))))
	(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.
	    (while file-alist
	      (setq elt (car file-alist)
		    file-alist (cdr file-alist))
	      (when (and (eq (cadr elt) t) ; directory
			 (not (string-match "\\`\\.\\.?\\'" (car elt))))
		(setq elt (expand-file-name (car elt) dir))
		(insert "\n" elt ":\n")
		(ls-lisp-insert-directory
		 elt switches time-index wildcard-regexp full-directory-p)))))
    ;; 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:
    (if (eq (aref file (1- (length file))) ?/)
	(setq file (substring file 0 -1)))
    (let ((fattr (file-attributes file 'string)))
      (if fattr
	  (insert (ls-lisp-format file fattr (nth 7 fattr)
				  switches time-index (current-time)))
	(message "%s: doesn't exist or is inaccessible" file)
	(ding) (sit-for 2)))))		; to show user the message!

(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))))))

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

(defsubst ls-lisp-string-lessp (s1 s2)
  "Return t if string S1 is less than string S2 in lexicographic order.
Case is significant if `ls-lisp-ignore-case' is nil.
Unibyte strings are converted to multibyte for comparison."
  (let ((u (compare-strings s1 0 nil s2 0 nil ls-lisp-ignore-case)))
    (and (numberp u) (< u 0))))

(defun ls-lisp-handle-switches (file-alist switches)
  "Return new FILE-ALIST sorted according to SWITCHES.
SWITCHES is a list of characters.  Default sorting is alphabetic."
  ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
  (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
				 ;; 7th file attribute is file size
				 ;; Make largest file come first
				 (< (nth 7 (cdr y))
				    (nth 7 (cdr x)))))
			      ((setq index (ls-lisp-time-index switches))
			       (lambda (x y) ; sorted on time
				 (ls-lisp-time-lessp (nth index (cdr y))
						     (nth index (cdr x)))))
			      ((memq ?X switches)
			       (lambda (x y) ; sorted on extension
				 (ls-lisp-string-lessp
				  (ls-lisp-extension (car x))
				  (ls-lisp-extension (car y)))))
			      (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
	  (if (or (eq (cadr (setq el (car file-alist))) t) ; directory
                  (and (stringp (cadr el))
                       (file-directory-p (cadr el)))) ; symlink to a directory
	      (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
  ;; `t' or `nil', rather than list tails!)
  (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))

(defun ls-lisp-classify (filedata)
  "Append a character to each file name indicating the file type.
Also, for regular files that are executable, append `*'.
The file type indicators are `/' for directories, `@' for symbolic
links, `|' for FIFOs, `=' for sockets, and nothing for regular files.
\[But FIFOs and sockets are not recognized.]
FILEDATA has the form (filename . `file-attributes').  Its `cadr' is t
for directory, string (name linked to) for symbolic link, or nil."
  (let ((file-name (car filedata))
        (type (cadr filedata)))
    (cond (type
	   (cons
	    (concat file-name (if (eq type t) "/" "@"))
	    (cdr filedata)))
	  ((string-match "x" (nth 9 filedata))
	   (cons
	    (concat file-name "*")
	    (cdr filedata)))
	  (t filedata))))

(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))

;; From Roland McGrath.  Can use this to sort on time.
(defun ls-lisp-time-lessp (time0 time1)
  "Return t if time TIME0 is earlier than time TIME1."
  (let ((hi0 (car time0)) (hi1 (car time1)))
    (or (< hi0 hi1)
	(and (= hi0 hi1)
	     (< (cadr time0) (cadr time1))))))

(defun ls-lisp-format (file-name file-attr file-size switches time-index now)
  "Format one line of long ls output for file FILE-NAME.
FILE-ATTR and FILE-SIZE give the file's attributes and size.
SWITCHES, TIME-INDEX and NOW give the full switch list and time data."
  (let ((file-type (nth 0 file-attr))
	;; t for directory, string (name linked to)
	;; for symbolic link, or nil.
	(drwxrwxrwx (nth 8 file-attr)))	; attribute string ("drwxrwxrwx")
    (concat (if (memq ?i switches)	; inode number
		(let ((inode (nth 10 file-attr)))
		  (if (consp inode)
		      (if (consp (cdr inode))
			  ;; 2^(24+16) = 1099511627776.0, but
			  ;; multiplying by it and then adding the
			  ;; other members of the cons cell in one go
			  ;; loses precision, since a double does not
			  ;; have enough significant digits to hold a
			  ;; full 64-bit value.  So below we split
			  ;; 1099511627776 into high 13 and low 5
			  ;; digits and compute in two parts.
			  (let ((p1 (* (car inode) 10995116.0))
				(p2 (+ (* (car inode) 27776.0)
				       (* (cadr inode) 65536.0)
				       (cddr inode))))
			    (format " %13.0f%05.0f "
				    ;; Use floor to emulate integer
				    ;; division.
				    (+ p1 (floor p2 100000.0))
				    (mod p2 100000.0)))
			(format " %18.0f "
				(+ (* (car inode) 65536.0)
				   (cdr inode))))
		    (format " %18d " inode))))
	    ;; nil is treated like "" in concat
	    (if (memq ?s switches)	; size in K
		(format ls-lisp-filesize-f-fmt
			(fceiling (/ file-size 1024.0))))
	    drwxrwxrwx			; attribute string
	    (if (memq 'links ls-lisp-verbosity)
		(format "%3d" (nth 1 file-attr))) ; link count
	    ;; Numeric uid/gid are more confusing than helpful;
	    ;; Emacs should be able to make strings of them.
	    ;; They tend to be bogus on non-UNIX platforms anyway so
	    ;; optionally hide them.
	    (if (memq 'uid ls-lisp-verbosity)
		;; uid can be a sting or an integer
		(let ((uid (nth 2 file-attr)))
                  (format (if (stringp uid)
			      ls-lisp-uid-s-fmt
			    ls-lisp-uid-d-fmt)
			  uid)))
	    (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))
                    (let ((gid (nth 3 file-attr)))
                      (format (if (stringp gid)
				  ls-lisp-gid-s-fmt
				ls-lisp-gid-d-fmt)
			      gid))))
	    (ls-lisp-format-file-size file-size (memq ?h switches))
	    " "
	    (ls-lisp-format-time file-attr time-index now)
	    " "
	    (propertize file-name 'dired-filename t)
	    (if (stringp file-type)	; is a symbolic link
		(concat " -> " file-type))
	    "\n"
	    )))

(defun ls-lisp-time-index (switches)
  "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

(defun ls-lisp-time-to-seconds (time)
  "Convert TIME to a floating point number."
  (+ (* (car time) 65536.0)
     (cadr time)
     (/ (or (nth 2 time) 0) 1000000.0)))

(defun ls-lisp-format-time (file-attr time-index now)
  "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,
depending on distance between file date and NOW.
All ls time options, namely c, t and u, are handled."
  (let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime
	 (diff (- (ls-lisp-time-to-seconds time)
		  (ls-lisp-time-to-seconds now)))
	 ;; 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
    (condition-case nil
	;; 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
	   (if (and (<= past-cutoff diff) (<= diff 0))
	       (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)))
	   time))
      (error "Unk  0  0000"))))

(defun ls-lisp-format-file-size (file-size human-readable)
  (if (not human-readable)
      (format (if (floatp file-size)
		  ls-lisp-filesize-f-fmt
		ls-lisp-filesize-d-fmt)
	      file-size)
    (if (< file-size 1024)
	(format " %4d" file-size)
      (do ((file-size (/ file-size 1024.0) (/ file-size 1024.0))
	   ;; kilo, mega, giga, tera, peta, exa
	   (post-fixes (list "k" "M" "G" "T" "P" "E") (cdr post-fixes)))
	  ((< file-size 1024)
	   (format " %3.0f%s"  file-size (car post-fixes)))))))

(provide 'ls-lisp)

;; arch-tag: e55f399b-05ec-425c-a6d5-f5e349c35ab4
;;; ls-lisp.el ends here